(use-modules (guix)
             (gcrypt pk-crypto)
             (gcrypt base16)
             (gcrypt base64)
             (srfi srfi-1)
             (srfi srfi-71)
             (ice-9 popen)
             (ice-9 match)
             (guix utils)
             (guix build utils)
             ((guix openpgp) #:select (openpgp-format-fingerprint))
             (rnrs bytevectors)
             (rnrs io ports))

(define url
  "https://git.savannah.gnu.org/git/guix.git")
(define commit
  "9744cc7b4636fafb772c94adb8f05961b5b39f16")
(define signer
  (base16-string->bytevector
   "3ce464558a84fdc69db40cfb090b11993d9aebb5"))

(define (sign-introduction commit signer)
  (let ((pipe pids
              (filtered-port (list (which "gpg") "-s" "-u"
                                   (bytevector->base16-string signer))
                             (open-input-string
                              (object->string
                               `((commit ,commit)
                                 (signer
                                  ,(bytevector->base16-string signer))))))))
    (let ((bv (get-bytevector-all pipe)))
      (and (every (compose zero? cdr waitpid) pids)
           bv))))

(define (channel-introduction commit signer)
  "Return an sexp representing a channel introduction."
  `(channel-introduction
    (version 0)
    (commit ,commit)
    (signer ,(openpgp-format-fingerprint signer))
    (signature ,(base64-encode (sign-introduction commit signer)))))

(define (radix-64-encode bv)
  (define (int24->bv int)
    (let ((bv (make-bytevector 3)))
      (bytevector-u8-set! bv 0 (ash (logand int #xff0000) -16))
      (bytevector-u8-set! bv 1 (ash (logand int #x00ff00) -8))
      (bytevector-u8-set! bv 2 (logand int #x0000ff))
      bv))

  (let ((str (base64-encode bv)))
    (string-append "-----BEGIN GUIX CHANNEL INTRODUCTION-----\n\n"
                   (insert-newlines str)
                   "="
                   (base64-encode
                    (int24->bv ((@@ (guix openpgp) crc24) bv)))
                   "\n\n"
                   "-----END GUIX CHANNEL INTRODUCTION-----\n")))

(define* (insert-newlines str #:optional (line-length 76))
  "Insert newlines in STR every LINE-LENGTH characters."
  (let loop ((result '())
             (str str))
    (if (string-null? str)
        (string-concatenate-reverse result)
        (let* ((length (min (string-length str) line-length))
               (prefix (string-take str length))
               (suffix (string-drop str length)))
          (loop (cons (string-append prefix "\n") result)
                suffix)))))


(radix-64-encode
 (string->utf8 (object->string (channel-introduction commit signer))))


(define (channel-introduction/compact commit signer)
  "Return a channel introduction as a bytevector, in compact binary
encoding."
  (let ((port get (open-bytevector-output-port)))
    (put-bytevector port
                    (u8-list->bytevector
                     (map char->integer (string->list "GXCI"))))
    (put-bytevector port #vu8(0 0 0 0))           ;version
    (let ((commit (base16-string->bytevector commit))
          (len    (make-bytevector 2)))
      (bytevector-u16-set! len 0 (bytevector-length commit)
                           (endianness big))
      (put-bytevector port len)
      (put-bytevector port commit))
    (put-bytevector port signer)
    (let ((signature (sign-introduction commit signer))
          (len       (make-bytevector 2)))
      (bytevector-u16-set! len 0 (bytevector-length signature)
                           (endianness big))
      (put-bytevector port len)
      (put-bytevector port signature))
    (force-output port)
    (get)))

(radix-64-encode
 (channel-introduction/compact commit signer))