securepassword.scm

#!/usr/bin/env bash
# -*- wisp -*-
exec -a "$0" guile -L $(dirname $(realpath "$0")) -e '(securepassword)' -c '' "$@"
; !#

;; Create secure passwords, usable on US and German keyboards without problems

(define-module (securepassword)
              #:export (letterblocks-nice main))

(import
    (only (srfi srfi-27) random-source-make-integers
      make-random-source random-source-randomize!)
    (only (srfi srfi-1) first second third iota)
    (srfi srfi-11 );; let-values
    (srfi srfi-42)
    (ice-9 optargs)
    (ice-9 format)
    (only (ice-9 rdelim) read-line)
    (ice-9 match)
    (ice-9 pretty-print))


;; newbase60 without yz_: 54 letters, 5.75 bits of entropy per letter.
(define qwertysafeletters "0123456789ABCDEFGHJKLMNPQRTUVWXabcdefghijkmnopqrstuvwx")
;; delimiters: 2.3 bits of entropy per delimiter, in the same place on main keys or the num-pad.
(define delimiters ".+-=")

(define random-source (make-random-source))
(random-source-randomize! random-source)


(define random-integer 
       (random-source-make-integers random-source))


(define (randomletter letters)
      (string-ref letters
        (random-integer
          (string-length letters))))


(define (letter-index letters letter)
    (string-index letters letter))

(define (block-value letterblock letters)
    (let loop
        ((rest letterblock)
          (value 0))
        (if (equal? "" rest)
           value
           (loop
               (string-drop rest 1)
               (+ (* (string-length letters) value)
                 (letter-index letters (string-ref rest 0)))))))

(define (checkchar letters delimiters . letterblocks)
    (let*
        ((value (block-value (apply string-append letterblocks) letters))
          (modvalue (string-length delimiters))
          (checksum (modulo value modvalue)))
        (string-ref delimiters checksum)))


(define (flatten e)
    (cond 
       ((pair? e)
         `(
           (,@ flatten (car e ))
           (,@ flatten (cdr e))))
       ((null? e)
         (list))
       (else 
         (list e))))



(define (blocks-to-passphrase blocks)
    (let check
        ((passphrase "")
          (blocks blocks))
        (cond
         ((null? blocks)
             passphrase)
         ((= (length blocks) 1)
             (string-append passphrase (first blocks)))
         (else
             (check
                 (string-append passphrase
                     (first blocks)
                     (string
                         (checkchar qwertysafeletters delimiters
                             (first blocks )
                             (second blocks))))
                 (cdr blocks))))))


(define (single-block)
    (apply string-append
        (map (λ (x) (string (randomletter qwertysafeletters)))
            (iota 4))))


(define (letterblocks blockcount)
    (let loop
        ((remaining blockcount)
          (blocks '()))
        (if (zero? remaining)
           (blocks-to-passphrase (reverse blocks))
           (loop
               (- remaining 1)
               (cons (single-block) blocks)))))


(define (letterblock-invalid? password)
    (let loop
        ((rest password)
          (count 5))
        (if (< (string-length rest) 5)
           (values #f #f #f)
           (let*
               ((check (string (string-ref rest 4)))
                 (block1 (string-take rest 4))
                 (block2
                     (string-take (string-drop rest 5)
                         (min 4 (- (string-length rest) 5))))
                 (calck (string (checkchar qwertysafeletters delimiters block1 block2))))
               (if (not (equal? check calck))
                  (values check calck count)
                  (loop (string-drop rest 5)
                         (+ count 5)))))))


(define (lines-from-file filepath)
   (let ((port (open-input-file filepath)))
     (let reader ((lines '()))
        (let ((line (read-line port)))
           (if (eof-object? line)
              (reverse! lines)
              (reader (cons line lines)))))))

(define (split-corpus-line line)
       "turn LINE into '(first-letter second-letter weight)

A LINE is formatted as cost ab, with cost a number and a and b the letters. For example:
10123151.392154863 en
0.020499130776997592 q6
"
       (define (log2 number)
                (/ (log number) (log 2)))
       (let*
          ((space-index (string-index line #\space))
            (weight (log2 (string->number (string-take line space-index))))
            (first-letter (string-ref line (+ space-index 1)))
            (second-letter (string-ref line (+ space-index 2))))
          (list first-letter second-letter weight)))
             

(define (shift-and-scale-cost line-costs upper-limit)
   "shift the COST to have cost values between zero (log-scale) and the UPPER-LIMIT."
   (let* 
       ((numbers (map (λ (x) (third x)) line-costs))
         (minimum (apply min numbers))
         (shifted-up (map (λ (x) (list (first x) (second x) (- (third x) minimum))) line-costs))
         (shifted-numbers (map (λ (x) (third x)) shifted-up))
         (maximum (apply max shifted-numbers))
         (scaling-factor (/ upper-limit maximum)))
       (format #t "Scaling factor: ~a\n" scaling-factor)
       (map (λ(x) (list (first x) (second x) (inexact->exact (floor (* scaling-factor (third x))))))
           shifted-up)))


(define (collapse-weighting letters cost)
   (define (index-value char)
            (string-index letters char))
   (let ((collapsed (make-string (expt (string-length letters) 2) (string-ref letters 0))))
       (let update-string ((cost cost))
         (if (null? cost)
           collapsed
           (let*
              ((element (car cost))
                (one (first element))
                (two (second element))
                (val (third element))
                (idx (+ (index-value two) (* (index-value one) (string-length letters)))))
              (string-set! collapsed idx val)
              (update-string (cdr cost)))))))

(define weightletters (string-append qwertysafeletters delimiters " "))
(define scalingfactor-inverse (/ 1 2.00834859456416))
(define weight-collapsed "rmjjkkmkjjNTRRPPULMWRWMNFMNRUTJXTXWfWUQMUWdVUVFTeURJQapTiUsommkkmkkmpUTTVQQTTFKPTNPDHRPLRHaXXWXWaUJFUVTLWQXaRNPfUmVjXoqjjjjkijiiQTVVQQUKKRMTHPHNPLUPQWabXaXaQQJRXWUdRUcaPQQbkWgXomiiiiiihiiRPQWNUQJKMVQML8UPJMHQWXWaVWXLQFUaTLLBVWWRFQTjXiWnkhhihihhihNLMMPNNLTMVTHJGUNKKPKTaWTVUVQGURTMRVAQUURGPVjagTnmhhhhhihhhQQPLMTKQHNHVPTRQLPUQJUTXWVXNMMLQWQGQLKaQQHLQiQgNokhhhhhmhhgURNQHKQNFLKNJLCGGRKHKUTXUXTQRJTPTLFQQGVNAULQiRgQojhhhhihhhhMMJRJQPGGFFQGLJHPHFMJUUVWVWJLDFKTQQKKRUPGCJQhPeMnkhhhhhihhiKNLLJLQPKPNQFJCPKHLGGVVVWVXMMQHTRbDP8GUNBKLThPfMmkiijjjjjknPNHJQKJFFQHTEPJGLHGKMVVTUTUGNHELTGAFLRUP9NNQiQfKmLXUVVURNQMcbddbafVUadefdWffaXVXcogiagfeeUikqTiapjjqcaabPdNkPRURQPRQRQdeaWaWaRRXabgUNbUbaVJpLRbsXQUnbHQKnHRnVRoQNMfHbLhRTVUPQPKRLcVcgjVVeTbbaVaTbcVbRPmJLPfTGneHKJNnL6gXQfKMHbWcPiQUTPRRPQKMdXVegeWXWUbbfdWeXecWTrQHbrLLUrVKUUnQ6kcbkVQKbMcUiQQPRQLLMMRdadebabVMWccfcTghddfbdifgUfcgqNahoUdaqnfmfajaMeXgRWTPMTRQPLcabdabUTMUbVRWGaaaTUPoMNHnTNNoRRNTnDJpUTjQLGWFbKfHULMMNMPTQacWUfVacHRaXfgKcabUWHkUDRrRPcjNDdfkJFqWNiPRFaLaThTPVMLPNNMNdUXXdVdWMVbVTVQWfWUUJqNJPpPWJoMEaKnKLcQNkMRBXJVQeDJKFFFEGLRTNPRTNRRVRLNLWPRPQRQJpRMJjPTUbDKHGkTFTTJmFECaCRDaLPNQJMKJHGaVQdbUXTNVXWTfNTVXUXNoPPNmVManQJVhpTJnTPmQUEaQXMfRPQLUNKHFGgWXXeacQMVbUUaKUaWVTNoNRTpPRNpTWEJkL4TWUjdMQaPbQhJRRXXNNLMNeaWbeTWXQTcaRbTUXXVbVrTcRpTQQqKTLVoVQiUPmHNHaJbLgLQULNHHJPKeaceeaeVPaVUdaLXhgXXMpHKQnRRPkMNQQoNQbQXjRNFaKXViMTUTPLLJTHeQcheUeWPVgXWdPcbbTQLoMMUmiFkiUWMUnRQqfVjVNDXNbLgHLGGJLRFCJWJLJVHKDHAWNTHQWVWRWRVDNFN7PEUNJNGPP6ELXmEbAQ7RDaQVRNPKNJJHeVddgXXQMWcbbdLceVaaMnTQRqLTfkLKHQmGLMRPkFMPaKbRhPVTTQNMJMTeVcafbUeUVacXeHceacUToRdToMQqkUNTbnRRoeQhRcgXJaNgXUePNQLKKHXVXWaUaRHVbXeWCdeQUQQMVTaXbWiUMXmqRdEifaNLbNWMdEhPRQLLKPKPFXWcacRaRNQXVbXDVRRWXKjHJRqaVHmKKJJoHJUQPaVMDbEbUgFQNQHQUELEbUTWeVUUTTVcUaLVVQRVPoGKNrLMjpNPNKnMLcURiFQFXWWHfJXLPKNNKKDQLUPUQKMLKUWHUDNXLUFbXTQQWPJMW6MRFVTLQLQQTJQUFXGeUdbXbUVVWTQUTWMVPQGQQQdQQUWDMPFnuusksutrhru.gqbxxxwpkjiRmatVcbXVWVWXVLNQGMTMdKNQNLLDNJBLJXsmfh.gmisifgirfWrqorfiUhQfXpXXbVXTUVTVRNXVTMUJKVVTQbQKTQMLBrbomrec=oatidtjdomqoidbfMhanVdaccacWRWWUUVaTMTJUWRXVTQbVRRDwjgo-jjjxehjmsibrposjmenWkdxXjgedabaWWWkXWdaVbPVVXVXQXaPTWXtttvssuu+gqv prk=.vtrrrqTog-TccWTUUVeWUXVQPRUJMQXTLPQVTNPR9siifusmhscfhkthcsntodienMhavPWaRURRQTWRXMTWTNNFHPURMJQUQQHFrggg+inprdnioogXsrrqfffmTkbwNUWPNMRMPETMNQUTTQMPJTQRNRRQULFwjei+hphvdmrstfXvqwqfpTkQjdxHbbRMHNLHLLcTNNPQTGNRQMVHPQQPTLrr.t+svrheru-upeux.krfkiViVsBMPNNM6C6JQFQFABCFR56KJJNJ6RCNJnaUbqcWUdaaUXjecVaVnWWQULVNeQRVUTKNJRGQVWLTQHRQNLVMPLQUTPWLsgekviihpXmjorfWpospihdjUjWrabbbWVQQTRVMQNTNTQKQRVNQMRKPNQBvodjwjievbjtirsceppqghXjJiVwVabhRJRPVNWVVWaXaTURVTWWNWXTUbLupr+.r.ovhsnvujfmvxsnmesVnd=URbbRLQKeFXRaUWMQTPUTPLQPWbHUPXmqtsktqqnjouxqrbxsttorkjNkUucefbdUQUNRRKLQXRPTKLDJTFRLTDTNFsdfjtpgoqVgigrqbtnqpadbhNjepDRVRHM04L4UQRQQQU3JF6QQ54RQF94MWacafcXXXbRWaXchbbdpWeUcFPRgQhebbaaQRUWWbTTPQUQPPUQVFWRMRWLwrsv+rsqvgsruvndrvwtnpboRme+bcdVKTQPQNVXVVTVVUKNUWQWLRPTRVKtnxk.mprwfpokutfnw.rmofpWng+XdfVXQNNTPaXWXbUXXTRWVUWQWbUQVQumnj-mnwwdknmunbuuutiqkrang+JQUQJKXLBHGMLeLNQLJNKQHbJQTLJKEoptpsurmpdmt.iqXwwvhhhhgJgLtcaecTJWREBHGLLMUQUFDHUDWPKQLWRFpbfdvdiXrVWehucaihddhWXeGjcmRWVbP8fR98MRTVRNTTRMUKDLHTVLRUMucegvdeqvdbdmsdbmkfqXidhTgTpeibXTVWPbWQRNaVTTPTNPNQR4PQDGKPjjkcjjbekbhgdimafnofhdbfUhbmomjiihiggghfajgcccbbaddbNbbddePigjihghgffdgfgkbhjhgchbmQfHvjebXWUTMNQPLQLMMQLNHNXJLCMRFKKKQTPNNRPMPKQUQKQMQVWJNPTNdXgjkmkhheedffjjhihiihgihjfibiifhiakkkiijijihgkihkckmkhigceUqaqacaUUUUTQPNNWQTdTNMKNNfRULdQNQLhWbjXagXWRfifbaTbgeWVcfJJWkrqsronmmjkjuuquttttrtsurtkstrstg.wu+xvvvxrtwvvtmt.xwvxjjnrr=")


(define (weighting-from-corpusfile filename)
   "this is how the weighting above was calculated"
   (let*
       ((cost (map split-corpus-line (lines-from-file filename)))
         (letters weightletters)
         (shifted (shift-and-scale-cost cost (- (string-length letters) 1))))
       (collapse-weighting letters
           (map (λ (x) (list (first x) (second x) (string-ref letters (third x))))
               shifted))))

(define (recreate-corpus-from-weighting)
       "Expand the weight string back into a full corpus by using the weightletters"
       (let expander
           ((weightleft weight-collapsed)
             (letter1 weightletters)
             (letter2 weightletters))
           (cond
             ((string-null? weightleft)
               #t)
             ((string-null? letter1)
               (error "could not expand the whole corpus. Letters left: ~a" weightleft))
             ((string-null? letter2)
               (expander weightleft (string-drop letter1 1) weightletters))
             (else
               (let ((cost (expt 2 (* scalingfactor-inverse (string-index weightletters (string-ref weightleft 0))))))
                   (format #t "~f ~a~a\n" cost (string-ref letter1 0) (string-ref letter2 0)))
               (expander
                  (string-drop weightleft 1)
                  letter1
                  (string-drop letter2 1))))))

(define (bigram->weight bigram)
       "Calculate the weight of the given bigram in a corpus"
       (let*
           ((letter1 (string-ref bigram 0))
             (letter2 (string-ref bigram 1))
             (idx1 (string-index weightletters letter1))
             (idx2 (string-index weightletters letter2))
             ;; for downcased bigrams (for phonetics) we might have to get the uppercase version
             (idx1 (if idx1 idx1 (string-index weightletters (char-upcase letter1))))
             (idx2 (if idx2 idx2 (string-index weightletters (char-upcase letter2))))
             (len (string-length weightletters))
             (costchar (string-ref weight-collapsed (+ (* idx1 len) idx2))))
           (expt 2 (* scalingfactor-inverse (string-index weightletters costchar)))))

(define (word-weight word)
       "calculate the probability weight of the given word to appear in a corpus given by the weight-collapsed"
       (let loop
           ((s (string-append " " word " "))
             (cost 0))
           (cond
             ((string-null? (string-drop s 1))
               cost)
             ((string-null? (string-drop s 2))
               cost)
             (else
               (loop 
                   (string-drop s 2)
                   (+ cost (bigram->weight (string-take s 2))))))))


(define* (string-replace-substring s substr replacement #:optional (start 0) (end (string-length s)))
       "Replace every instance of substring in s by replacement."
       (let ((substr-length (string-length substr)))
          (if (zero? substr-length)
             (error "string-replace-substring: empty substr")
             (let loop
                 ((start start)
                   (pieces (list (substring s 0 start))))
                 (let ((idx (string-contains s substr start end)))
                   (if idx
                     (loop (+ idx substr-length)
                           (cons* replacement
                                  (substring s start idx)
                                  pieces))
                     (string-concatenate-reverse
                                                (cons (substring s start)
                                                    pieces))))))))


(define* (letterblocks-nice blockcount #:key (best-of 8))
     "Generate BEST-OF letterblocks and return the one most likely to appear in the corpus given by weight-collapsed

best-of 8 consumes 3 bits of entropy, but creates passwords which are easier to remember. "
     (define (delimiters-to-space s)
            "replace all delimiters by spaces"
            (let replace
              ((s s)
                (delim delimiters))
              (if (string-null? delim)
                s
                (replace
                    (string-replace-substring s (string-take delim 1) " ")
                    (string-drop delim 1)))))
     (car
         (sort
             (map (λ (x) (letterblocks blockcount))
                 (iota best-of))
             (λ (a b)
                  (> 
                      (word-weight (delimiters-to-space (string-downcase a)))
                      (word-weight (delimiters-to-space (string-downcase b))))))))


(define (help args)
       (format #t "Usage: ~a [options]

Options:
  [<length> [<password-type>]]            create password
   --check <password>                     verify the checksums
   --help                                 show this message
" (first args)))

(define (main args)
 (cond
   ((and (> (length args) 1) (equal? "--help" (second args)))
     (help args))
   ((and (> (length args) 2) (equal? "--check" (second args)))
     (let-values (((check calck count) (letterblock-invalid? (third args))))
        (cond 
            (count
                (format #t "letterblock invalid. First failed checksum: ~a should have been ~a at position ~a\n"
                    check calck count)
                (exit 1))
            (else
                (format #t "valid letterblock password\n")))))
   (else
     (let
      (
        (len
          (if (<= 2 (length args))
             (string->number (second args))
             12)))
      (display (letterblocks-nice (floor (/ len 4))))
      (newline)))))