signify.rkt

#lang racket

(provide (struct-out public-key)
         (struct-out signature)
         (struct-out secret-key)
         read-signify-file
         parse-pk
         parse-sk
         parse-sig
         format-pk
         format-sk
         format-sig
         )

(require racket/random)
(require net/base64)
(require sha)

(require bitsyntax)
(require racl)
(require blowfish/bcrypt-hash)

(define (read-signify-file filename)
  (base64-decode (string->bytes/utf-8 (cadr (string-split (file->string filename) "\n")))))

(define ID-BYTES 8)
(define PK-BYTES 32)
(define SK-BYTES 64)
(define SIG-BYTES 64)
(define SK-SALT-BYTES 16)
(define SK-CHECKSUM-BYTES 8)

(struct public-key (id bytes) #:transparent)
(struct signature (key-id bytes) #:transparent)
(struct secret-key (id bytes) #:transparent)

(define (format-pk pk)
  (bit-string (#"Ed" :: binary)
              ((public-key-id pk) :: binary bytes ID-BYTES)
              ((public-key-bytes pk) :: binary bytes PK-BYTES)))

(define (parse-pk blob)
  (bit-string-case blob
    ([ (= #"Ed" :: binary bytes 2)
       (id :: binary bytes ID-BYTES)
       (pk :: binary bytes PK-BYTES) ]
     (public-key (bit-string->bytes id)
                 (bit-string->bytes pk)))))

(define (format-sig sig)
  (bit-string (#"Ed" :: binary)
              ((signature-key-id sig) :: binary bytes ID-BYTES)
              ((signature-bytes sig) :: binary bytes SIG-BYTES)))

(define (parse-sig blob)
  (bit-string-case blob
    ([ (= #"Ed" :: binary bytes 2)
       (key-id :: binary bytes ID-BYTES)
       (sig :: binary bytes SIG-BYTES) ]
     (signature (bit-string->bytes key-id)
                (bit-string->bytes sig)))))

(define (prompt-and-read prompt)
  (printf "~a: " prompt)
  (flush-output)
  (read-line))

(define (read-passphrase) (prompt-and-read "passphrase"))

(define (read-passphrase/confirm)
  (define p1 (read-passphrase))
  (define p2 (prompt-and-read "confirm passphrase"))
  (and (equal? p1 p2) p1))

(define (kdf salt rounds passphrase keylen)
  (if (zero? rounds)
      (make-bytes keylen)
      (bcrypt-pbkdf (string->bytes/utf-8 passphrase) salt keylen rounds)))

(define (format-sk sk passphrase
                   #:rounds [kdf-rounds 42]
                   #:salt [salt (crypto-random-bytes SK-SALT-BYTES)])
  (bit-string (#"Ed" :: binary bytes 2)
              (#"BK" :: binary bytes 2)
              (kdf-rounds :: integer bytes 4)
              (salt :: binary bytes SK-SALT-BYTES)
              ((sha512 (secret-key-bytes sk)) :: binary bytes SK-CHECKSUM-BYTES)
              ((secret-key-id sk) :: binary bytes ID-BYTES)
              ((bcrypt-bytes-xor (kdf salt kdf-rounds passphrase SK-BYTES) (secret-key-bytes sk))
               :: binary bytes SK-BYTES)))

(define (parse-sk blob)
  (bit-string-case blob
    ([ (= #"Ed" :: binary bytes 2)
       (= #"BK" :: binary bytes 2)
       (kdf-rounds :: integer bytes 4)
       (salt :: binary bytes SK-SALT-BYTES)
       (checksum :: binary bytes SK-CHECKSUM-BYTES)
       (id :: binary bytes ID-BYTES)
       (seckey :: binary bytes SK-BYTES) ]
     (let ((salt (bit-string->bytes salt))
           (checksum (bit-string->bytes checksum)) ;; SHA512 of the unencrypted key
           (id (bit-string->bytes id))
           (seckey (bit-string->bytes seckey)))
       (define clearkey
         (bcrypt-bytes-xor (kdf salt kdf-rounds (read-passphrase) (bytes-length seckey))
                           seckey))
       (and (equal? checksum (subbytes (sha512 clearkey) 0 (bytes-length checksum)))
            (secret-key id clearkey))))))

(module+ main
  (define pk (parse-pk (read-signify-file "k.pub")))
  (define sk (parse-sk (read-signify-file "k.sec")))
  (define sig (parse-sig (read-signify-file "sums.sig")))
  (printf "pk: ~a ~a\n"
          (bytes->hex-string (public-key-id pk))
          (bytes->hex-string (public-key-bytes pk)))
  (printf "sk: ~a ~a\n"
          (bytes->hex-string (secret-key-id sk))
          (bytes->hex-string (secret-key-bytes sk)))
  (printf "sig: ~a ~a\n"
          (bytes->hex-string (signature-key-id sig))
          (bytes->hex-string (signature-bytes sig)))
  (printf "newsig: ~a\n"
          (bytes->hex-string (subbytes (crypto-sign (file->bytes "sums")
                                                    (secret-key-bytes sk))
                                       0
                                       SIG-BYTES)))
  (printf "text of signed message:\n~a\n"
          (crypto-sign-open (bytes-append (signature-bytes sig)
                                          (file->bytes "sums"))
                            (public-key-bytes pk)))
  (newline)
  (printf "~a\n" (base64-encode (bit-string->bytes (format-sk sk "hello")) #""))
  )

ssh-agent.rkt

#lang racket/base

(require bitsyntax)
(require racket/unix-socket)
(require net/base64)

(require "signify.rkt")

(define-values (i o) (unix-socket-connect (getenv "SSH_AUTH_SOCK")))

(define SSH_AGENT_FAILURE 5)
(define SSH_AGENT_SUCCESS 6)
(define SSH_AGENTC_REQUEST_IDENTITIES 11)
(define SSH_AGENT_IDENTITIES_ANSWER 12)
(define SSH_AGENTC_SIGN_REQUEST 13)
(define SSH_AGENT_SIGN_RESPONSE 14)
(define SSH_AGENTC_ADD_IDENTITY 17)
(define SSH_AGENTC_REMOVE_IDENTITY 18)
(define SSH_AGENTC_REMOVE_ALL_IDENTITIES 19)
(define SSH_AGENTC_ADD_SMARTCARD_KEY 20)
(define SSH_AGENTC_REMOVE_SMARTCARD_KEY 21)
(define SSH_AGENTC_LOCK 22)
(define SSH_AGENTC_UNLOCK 23)
(define SSH_AGENTC_ADD_ID_CONSTRAINED 25)
(define SSH_AGENTC_ADD_SMARTCARD_KEY_CONSTRAINED 26)
(define SSH_AGENTC_EXTENSION 27)
(define SSH_AGENT_EXTENSION_FAILURE 28)

(struct identity (blob comment) #:transparent)

(define (write-packet o type bs)
  (write-bytes (bit-string->bytes
                (bit-string ((+ 1 (bytes-length bs)) :: bits 32)
                            (type :: bits 8)
                            (bs :: binary)))
               o)
  (flush-output o))

(define (read-packet i)
  (bit-string-case (read-bytes 4 i)
    ([(len :: bits 32)]
     (bit-string-case (read-bytes len i)
       ([(type :: bits 8) (body :: binary)]
        (values type body))))))

(define (list-keys i o)
  (write-packet o SSH_AGENTC_REQUEST_IDENTITIES #"")
  (define-values (response-type body) (read-packet i))
  (when (not (= response-type SSH_AGENT_IDENTITIES_ANSWER))
    (error 'list-keys "Invalid response from SSH agent: ~a" response-type))
  (bit-string-case body
    ([ (nkeys :: bits 32) (body :: binary) ]
     (let loop ((acc-rev '()) (nkeys nkeys) (body body))
       (if (zero? nkeys)
           (reverse acc-rev)
           (bit-string-case body
             ([ (bloblen :: bits 32) (blob :: binary bytes bloblen)
                (commentlen :: bits 32) (comment :: binary bytes commentlen)
                (rest :: binary) ]
              (loop (cons (identity (bit-string->bytes blob)
                                    (bytes->string/utf-8 (bit-string->bytes comment)))
                          acc-rev)
                    (- nkeys 1)
                    rest))))))))

(define (blob-ed25519-key blob)
  (bit-string-case blob
    ([ (= 11 :: bits 32) (= #"ssh-ed25519" :: binary bytes 11)
       (= 32 :: bits 32) (pk :: binary bytes 32) ]
     (bit-string->bytes pk))
    (else #f)))

(define (sign data id i o)
  (write-packet o SSH_AGENTC_SIGN_REQUEST
                (bit-string->bytes
                 (bit-string ((bytes-length (identity-blob id)) :: bits 32)
                             ((identity-blob id) :: binary)
                             ((bytes-length data) :: bits 32)
                             (data :: binary)
                             (0 :: bits 32))))
  (define-values (response-type body) (read-packet i))
  (when (not (= response-type SSH_AGENT_SIGN_RESPONSE))
    (error 'sign "Invalid response from SSH agent: ~a" response-type))
  (bit-string-case body
    ([ (len :: bits 32) (signature :: binary bytes len) ]
     (bit-string->bytes signature))))

(let ((ids (filter (lambda (i) (blob-ed25519-key (identity-blob i))) (list-keys i o))))
  (for-each writeln ids)
  (newline)
  (for-each (lambda (id)
              (define pk (public-key #"xxxxxxxx" (blob-ed25519-key (identity-blob id))))
              (define s (sign #"hello" id i o))
              (writeln pk)
              (writeln s)
              (bit-string-case s
                ([ (= 11 :: bits 32) (= #"ssh-ed25519" :: binary bytes 11)
                   (len :: bits 32) (sig-bs :: binary bytes len) ]
                 (let ((sig (signature #"xxxxxxxx" sig-bs)))
                   (displayln "untrusted comment: the public key")
                   (displayln (base64-encode (bit-string->bytes (format-pk pk)) #""))
                   (newline)
                   (displayln "untrusted comment: from ssh")
                   (displayln (base64-encode (bit-string->bytes (format-sig sig)) #"")))))
              (newline))
            ids)
  )

ssh-keys.rkt

#lang racket

(require net/base64)
(require bitsyntax)
(require blowfish/bcrypt-hash)
(require crypto)
(require crypto/libcrypto)

(define-syntax ssh:string
  (syntax-rules ()
    [(_ #t input ks kf)
     (bit-string-case input
       ([ (len :: bits 32) (bs :: binary bytes len) (rest :: binary) ]
        (ks (bit-string->bytes bs) rest))
       (else
        (kf)))]
    [(_ #f bs)
     (bit-string ((bytes-length bs) :: bits 32)
                 (bs :: binary))]))

(define-syntax ssh:repeat
  (syntax-rules ()
    [(_ #t input ks kf parser)
     (let loop ((acc-rev '()) (rest input))
       (bit-string-case rest
         ([ (item :: parser) (rest :: binary) ] (loop (cons item acc-rev) rest))
         (else (ks (reverse acc-rev) rest))))]
    [(_ #t input ks kf ntimes parser)
     (let loop ((acc-rev '()) (rest input) (n ntimes))
       (if (zero? n)
           (ks (reverse acc-rev) rest)
           (bit-string-case rest
             ([ (item :: parser) (rest :: binary) ]
              (loop (cons item acc-rev) rest (- n 1))))))]
    [(_ #f items0 parser)
     (let loop ((items items0))
       (match items
         ['() #""]
         [(cons item items) (bit-string (item :: parser) (loop items))]))]))

(define-syntax ssh:padding
  (syntax-rules ()
    [(_ #t input ks kf)
     (let loop ((expected 1) (rest input))
       (bit-string-case rest
         ([ (= expected) (rest :: binary) ] (loop (+ expected 1) rest))
         ([ ] (ks 'padding-ok #""))
         (else (kf))))]))

(define (read-ssh-private-key filename [passphrase-bytes #f])
  (call-with-input-file filename
    (lambda (p)
      (and (equal? (read-line p) "-----BEGIN OPENSSH PRIVATE KEY-----")
           (let ((blob (let collect ((acc '()))
                         (match (read-line p)
                           ["-----END OPENSSH PRIVATE KEY-----"
                            (base64-decode (string->bytes/latin-1 (string-join (reverse acc))))]
                           [line
                            (collect (cons line acc))]))))
             (bit-string-case blob
               ([ (= #"openssh-key-v1\0" :: binary bytes 15)
                  (ciphername :: (ssh:string))
                  (kdfname :: (ssh:string))
                  (kdfoptions :: (ssh:string))
                  (= 1 :: bits 32) ;; OpenSSH only supports one key
                  (public-keys :: (ssh:repeat 1 (ssh:string)))
                  (private-keys :: (ssh:string)) ]
                (decode-private-keys passphrase-bytes
                                     ciphername
                                     kdfname
                                     kdfoptions
                                     (car public-keys)
                                     private-keys))
               (else #f)))))))

(define (decode-private-keys passphrase-bytes
                             ciphername
                             kdfname
                             kdfoptions
                             public-key
                             private-keys)
  (define pk-bytes
    (bit-string-case public-key
      ([ (= #"ssh-ed25519" :: (ssh:string))
         (bs :: (ssh:string)) ]
       bs)))
  (define (decode-decrypted blob)
    ;; Oddly, this only partially lines up with the spec at
    ;; https://cvsweb.openbsd.org/cgi-bin/cvsweb/src/usr.bin/ssh/PROTOCOL.key?annotate=1.1
    ;;
    ;; Specifically, contra spec, after the checkints, we seem to have
    ;; the public key again followed by the private key bytes and then
    ;; a comment string.
    ;;
    ;; The code (sshkey.c) does this:
    ;;  - retrieve a key type string
    ;;  - dispatch on it
    ;;  - for ed25519, read a string with the PK, then a string with the SK
    ;;  - checks the sizes to ensure they are correct for ed25519
    ;;
    ;; This is what the PROTOCOL.key documentation says to do. It's
    ;; not what actually needs to be done.
    ;;
    ;; [ (checkint1 :: bits 32) (= checkint1 :: bits 32) ;; must be the same
    ;;   (keys :: (ssh:repeat 1 (ssh:repeat 2 (ssh:string))))
    ;;   (= 'padding-ok :: (ssh:padding)) ]
    ;;
    (bit-string-case blob
      ([ (checkint1 :: bits 32) (= checkint1 :: bits 32) ;; must be the same
         (= #"ssh-ed25519" :: (ssh:string))
         (pk-bytes-in-sk :: (ssh:string))
         (sk :: (ssh:string))
         (comment :: (ssh:string))
         (= 'padding-ok :: (ssh:padding))
         ]
       (and (equal? pk-bytes pk-bytes-in-sk)
            (list pk-bytes sk (bytes->string/utf-8 comment))))
      (else #f)))
  (match* (ciphername kdfname)
    [(#"none" #"none")
     (decode-decrypted private-keys)]
    [(#"aes256-ctr" #"bcrypt")
     (define keylen (/ 256 8)) ;; aes256 = 256 bit key length
     (define ivlen (/ 128 8)) ;; fixed block size of 128 bits
     (bit-string-case kdfoptions
       ([ (salt :: (ssh:string))
          (rounds :: bits 32) ]
        (when (not passphrase-bytes) (error 'read-ssh-private-key "Passphrase required"))
        (bit-string-case (bcrypt-pbkdf passphrase-bytes salt (+ keylen ivlen) rounds)
          ([ (key :: binary bytes keylen) (iv :: binary bytes ivlen) ]
           (decode-decrypted
            (parameterize ((crypto-factories (list libcrypto-factory)))
              (decrypt '(aes ctr) (bit-string->bytes key) (bit-string->bytes iv) private-keys)))))))]
    [(_ _)
     (error 'read-ssh-private-key "Unsupported private-key cipher/kdf")]))

(pretty-print (read-ssh-private-key "passphraseless"))
(pretty-print (read-ssh-private-key "with-passphrase-ssob" #"ssob"))
(pretty-print (read-ssh-private-key "with-passphrase-ssob" #"ssob-wrong-passphrase"))