;; Michael Orlov <orlovm@cs.bgu.ac.il>
;; April 2003
;;
;; Implementation of DES and crypt(3) in Scheme

;; =====================================
;; Primitive high-order functions
;; =====================================

(define fold-left
  (lambda (op init seq)
    (if (null? seq)
        init
        (fold-left op (op init (car seq))
                   (cdr seq)))))

(define flatmap
  (lambda (proc . seqs)
    (apply append (apply map proc seqs))))

;; =====================================
;; Primitive functions for lists
;; =====================================

(define first-n
  (lambda (s n)
    (if (zero? n)
        (values '() s)
        (call-with-values
            (lambda ()
              (first-n (cdr s) (1- n)))
          (lambda (rest-n rest-s)
            (values (cons (car s) rest-n)
                    rest-s))))))

;; args: list, number of elems in group
(define group
  (lambda (s n)
    (if (null? s)
        '()
        (call-with-values
            (lambda ()
              (first-n s n))
          (lambda (grp rest-s)
            (cons grp (group rest-s n)))))))

(define 1+ add1)
(define 1- sub1)

;; =====================================
;; bits <-> number
;; =====================================

;; access given bit of a number
(define bit
  (lambda (number bit)
    (modulo (quotient number (expt 2 bit)) 2)))

;; convert list of bits to non-negative number
(define bits->number
  (lambda (bits)
    (fold-left (lambda (acc bit)
                 (+ (* acc 2) bit))
               0 bits)))

;; convert number to list of bits
;; use min-length of 0 for minimum possible length
(define number->bits
  (letrec
      ((number->bits
        (lambda (number min-length)
          (if (and (zero? number)
                   (not (positive? min-length)))
              '()
              (cons (modulo number 2)
                    (number->bits (quotient number 2)
                                  (1- min-length)))))))
    (lambda (number min-length)
      (reverse (number->bits number min-length)))))

;; =====================================
;; Logical operations on single bits
;; =====================================

(define bit-not
  (lambda (bit)
    (- 1 bit)))

(define bit-and
  (lambda (b1 b2)
    (min b1 b2)))

(define bit-or
  (lambda (b1 b2)
    (max b1 b2)))

(define bit-xor
  (lambda (b1 b2)
    (modulo (+ b1 b2) 2)))

;; =====================================
;; Logical operations on bit lists
;; =====================================

(define bitwise-not
  (lambda (bits)
    (map bit-not bits)))

(define bitwise-and
  (lambda (bs1 bs2)
    (map bit-and bs1 bs2)))

(define bitwise-or
  (lambda (bs1 bs2)
    (map bit-or bs1 bs2)))

(define bitwise-xor
  (lambda (bs1 bs2)
    (map bit-xor bs1 bs2)))

;; =====================================
;; Logical operations on numbers
;; =====================================

(define xor
  (lambda (n1 n2)
    (let ((n1 (max n1 n2))
          (n2 (min n1 n2)))
      (let* ((bs1 (number->bits n1 0))
             (bs2 (number->bits n2 (length bs1))))
        (bits->number (bitwise-xor bs1 bs2))))))

;; k - number of bits
(define negate
  (lambda (n k)
    (bits->number (bitwise-not (number->bits n k)))))

;; k - number of bits
(define rol
  (lambda (n k shift)
    (let ((bits (number->bits n k)))
      (call-with-values
          (lambda ()
            (first-n bits shift))
        (lambda (grp rest-bits)
          (bits->number (append rest-bits grp)))))))

;; k - number of bits in each half
(define number->halves
  (lambda (n k)
    (let ((mod (expt 2 k)))
      (values (quotient n mod)
              (modulo n mod)))))

;; k - number of bits in each half
(define halves->number
  (lambda (n1 n2 k)
    (+ (* n1 (expt 2 k)) n2)))

;; =====================================
;; Permutations and bit selections
;; bits are numbered from 0, rtl
;; =====================================

;; select specified bits from a number
;; returns a number
(define select-bits
  (lambda (number bits)
      (let ((vec (list->vector
                  (number->bits number (1+ (apply max bits))))))
        (bits->number
         (map (lambda (bit)
                (vector-ref vec (- (vector-length vec) bit 1)))
              bits)))))

(define inverse-permutation
  (letrec
      ((fill (lambda (vec bits n)
               (if (not (null? bits))
                   (begin
                     (vector-set! vec (- (vector-length vec)
                                         (car bits) 1) n)
                     (fill vec (cdr bits) (1- n)))))))
    (lambda (perm)
      (let ((inv-vec (make-vector (length perm))))
        (fill inv-vec perm (1- (vector-length inv-vec)))
        (vector->list inv-vec)))))

;; =====================================
;; DES
;; See FIPS PUB 46-3
;; =====================================

;; standard s-box representation -> natural s-box representation
(define des-s-box->s-box
  (lambda (box)
    (let ((lines (group box 16)))
      (append (flatmap list (car lines) (cadr lines))
              (flatmap list (caddr lines) (cadddr lines))))))
    
(define des-standard-s-boxes
  '((14 4 13 1 2 15 11 8 3 10 6 12 5 9 0 7
     0 15 7 4 14 2 13 1 10 6 12 11 9 5 3 8
     4 1 14 8 13 6 2 11 15 12 9 7 3 10 5 0
     15 12 8 2 4 9 1 7 5 11 3 14 10 0 6 13)
    (15 1 8 14 6 11 3 4 9 7 2 13 12 0 5 10
     3 13 4 7 15 2 8 14 12 0 1 10 6 9 11 5
     0 14 7 11 10 4 13 1 5 8 12 6 9 3 2 15
     13 8 10 1 3 15 4 2 11 6 7 12 0 5 14 9)
    (10 0 9 14 6 3 15 5 1 13 12 7 11 4 2 8
     13 7 0 9 3 4 6 10 2 8 5 14 12 11 15 1
     13 6 4 9 8 15 3 0 11 1 2 12 5 10 14 7
     1 10 13 0 6 9 8 7 4 15 14 3 11 5 2 12)
    (7 13 14 3 0 6 9 10 1 2 8 5 11 12 4 15
     13 8 11 5 6 15 0 3 4 7 2 12 1 10 14 9
     10 6 9 0 12 11 7 13 15 1 3 14 5 2 8 4
     3 15 0 6 10 1 13 8 9 4 5 11 12 7 2 14)
    (2 12 4 1 7 10 11 6 8 5 3 15 13 0 14 9
     14 11 2 12 4 7 13 1 5 0 15 10 3 9 8 6
     4 2 1 11 10 13 7 8 15 9 12 5 6 3 0 14
     11 8 12 7 1 14 2 13 6 15 0 9 10 4 5 3)
    (12 1 10 15 9 2 6 8 0 13 3 4 14 7 5 11
     10 15 4 2 7 12 9 5 6 1 13 14 0 11 3 8
     9 14 15 5 2 8 12 3 7 0 4 10 1 13 11 6
     4 3 2 12 9 5 15 10 11 14 1 7 6 0 8 13)
    (4 11 2 14 15 0 8 13 3 12 9 7 5 10 6 1
     13 0 11 7 4 9 1 10 14 3 5 12 2 15 8 6
     1 4 11 13 12 3 7 14 10 15 6 8 0 5 9 2
     6 11 13 8 1 4 10 7 9 5 0 15 14 2 3 12)
    (13 2 8 4 6 15 11 1 10 9 3 14 5 0 12 7
     1 15 13 8 10 3 7 4 12 5 6 11 0 14 9 2
     7 11 4 1 9 12 14 2 0 6 10 13 15 3 5 8
     2 1 14 7 4 10 8 13 15 12 9 0 3 5 6 11)))

(define des-s-boxes (map des-s-box->s-box des-standard-s-boxes))
(define des-vec-s-boxes (map list->vector des-s-boxes))

;; ltr 1-based notation to rtl 0-based notation
;; assumes lsb bit is referenced
(define des-bits->bits
  (lambda (bits)
    (let ((k (apply max bits)))
      (map (lambda (ref) (- k ref))
           bits))))

(define des-standard-p
  '(16 7 20 21 29 12 28 17 1 15 23 26 5 18 31 10
    2 8 24 14 32 27 3 9 19 13 30 6 22 11 4 25))

(define des-p (des-bits->bits des-standard-p))

(define des-standard-e
  '(32 1 2 3 4 5 4 5 6 7 8 9 8 9 10 11
    12 13 12 13 14 15 16 17 16 17 18 19 20 21 20 21
    22 23 24 25 24 25 26 27 28 29 28 29 30 31 32 1))

(define des-e (des-bits->bits des-standard-e))

;; r - 32 bits, k - 48 bits
(define des-f
  (lambda (r k)
    (let ((s-inputs
           (map bits->number
                (group (bitwise-xor
                        (number->bits (select-bits r des-e) 48)
                        (number->bits k 48))
                       6))))
      (select-bits (bits->number
                    (flatmap (lambda (s-out)
                               (number->bits s-out 4))
                             (map vector-ref
                                  des-vec-s-boxes s-inputs)))
                   des-p))))

;; l,r - 32 bits, k - 48 bits
(define des-round
  (lambda (l r k)
    (values r
            (xor l (des-f r k)))))

(define des-standard-pc-1
  '(57 49 41 33 25 17 9 1 58 50 42 34 26 18
    10 2 59 51 43 35 27 19 11 3 60 52 44 36
    63 55 47 39 31 23 15 7 62 54 46 38 30 22
    14 6 61 53 45 37 29 21 13 5 28 20 12 4))

(define des-standard-pc-2
  '(14 17 11 24 1 5 3 28 15 6 21 10 23 19 12 4
    26 8 16 7 27 20 13 2 41 52 31 37 47 55 30 40
    51 45 33 48 44 49 39 56 34 53 46 42 50 36 29 32))

(define des-pc-1 (des-bits->bits des-standard-pc-1))
(define des-pc-2 (des-bits->bits des-standard-pc-2))

(define des-shifts
  '(1 1 2 2 2 2 2 2 1 2 2 2 2 2 2 1))

;; k - 64 bits
(define des-key-schedule
  (letrec
      ((sched
        (lambda (c d shifts)
          (if (null? shifts)
              '()
              (let ((c (rol c 28 (car shifts)))
                    (d (rol d 28 (car shifts))))
                (cons (select-bits (halves->number c d 28)
                                   des-pc-2)
                      (sched c d (cdr shifts))))))))
  (lambda (k)
    (call-with-values
        (lambda ()
          (number->halves (select-bits k des-pc-1) 28))
      (lambda (c d)
        (sched c d des-shifts))))))
    
(define des-standard-ip
  '(58 50 42 34 26 18 10 2 60 52 44 36 28 20 12 4
    62 54 46 38 30 22 14 6 64 56 48 40 32 24 16 8
    57 49 41 33 25 17 9 1 59 51 43 35 27 19 11 3
    61 53 45 37 29 21 13 5 63 55 47 39 31 23 15 7))

(define des-ip   (des-bits->bits des-standard-ip))
(define des-ip-1 (inverse-permutation des-ip))

;; m - 64 bits, k - 64 bits
(define des-invoke
  (letrec
      ((rounds
        (lambda (l r sched)
          (if (null? sched)
              (values l r)
              (call-with-values
                  (lambda ()
                    (des-round l r (car sched)))
                (lambda (l r)
                  (rounds l r (cdr sched))))))))
    (lambda (m schedule)
      (call-with-values
          (lambda ()
            (number->halves (select-bits m des-ip) 32))
        (lambda (l r)
          (call-with-values
              (lambda ()
                (rounds l r schedule))
            (lambda (l r)
              (select-bits (halves->number r l 32) des-ip-1))))))))

(define des-encrypt
  (lambda (m k)
    (des-invoke m (des-key-schedule k))))

(define des-decrypt
  (lambda (c k)
    (des-invoke c (reverse (des-key-schedule k)))))

;; =========================================
;; Crypt(3)
;; Works as follows:
;;   * password is viewed as 64-bit key
;;   * salt is viewed as 12-bit key
;;   * salt is used to augment E expansion
;;   * 0 is encrypted 25 times using the key
;;   * 64-bit result is padded with zeros to
;;     66-bit, then converted to 11 chars
;;     (6 bits per char)
;;   * salt is prepended to the final result
;; =========================================

;; [./0-9 A-Z a-z] -> [0,63]
(define salt-char->number
  (let ((char-dot   (char->integer #\.))
        (char-a-up  (char->integer #\A))
        (char-a-low (char->integer #\a)))
    (lambda (char)
      (let ((val (char->integer char)))
        (cond ((>= val char-a-low)
               (+ 12 26 (- val char-a-low)))
              ((>= val char-a-up)
               (+ 12 (- val char-a-up)))
              (else
               (- val char-dot)))))))

;; [0,63] -> [./0-9 A-Z a-z]
(define number->salt-char
  (let ((char-dot   (char->integer #\.))
        (char-a-up  (char->integer #\A))
        (char-a-low (char->integer #\a)))
    (lambda (num)
      (integer->char
       (cond ((> num (- 63 26))
              (+ char-a-low (- num (- 63 26) 1)))
             ((> num (- 63 26 26))
              (+ char-a-up (- num (- 63 26 26) 1)))
             (else
              (+ char-dot num)))))))

;; returns new des-e, augmented by salt,
;; which should be a 2-char string
;; This works as follows:
;;   * salt is viewed as 12 bits [b_5 .. b_0, b_11 .. b_6]
;;   * for each 0 <= i <= 11
;;       if b_i = 1
;;         swap E[i] <-> E[i+24]
(define salt-des-e
  (letrec
      ((swap (lambda (bits j base vec)
               (if (not (null? bits))
                   (begin
                     (if (= (car bits) 1)
                         (let ((index1 (+ base j))
                               (index2 (+ base j 24)))
                           (let ((temp (vector-ref vec index2)))
                             (vector-set! vec index2
                                          (vector-ref vec index1))
                             (vector-set! vec index1 temp))))
                     (swap (cdr bits) (1- j) base vec))))))
    (lambda (salt)
      (let ((salts-bits
             (map (lambda (index)
                    (number->bits (salt-char->number
                                   (string-ref salt index))
                                  6))
                  '(0 1)))
            (vec-e (list->vector des-e)))
        (swap (car  salts-bits) 5 0 vec-e)
        (swap (cadr salts-bits) 5 6 vec-e)
        (vector->list vec-e)))))

;; 8-byte string -> 64-bit key
(define string->key
  (lambda (str)
    (bits->number
     (flatmap (lambda (num)
                (number->bits num 8))
              (map char->integer
                   (string->list
                    (string-append
                     str
                     (make-string (- 8 (string-length str))
                                  #\nul))))))))

;; 64-bit key -> 11-byte string
;; (2 zero bits added at the right, then grouped by 6)
(define key->string
  (lambda (key)
    (list->string
     (map number->salt-char
          (map bits->number
               (group (append (number->bits key 64) '(0 0))
                      6))))))

;; 0-8-char password
;; 2-char salt (over [./0-9A-Za-z])
(define crypt3
  (letrec
      ((encrypt (lambda (m k n)
                  (if (zero? n) m
                      (encrypt (des-encrypt m k) k (1- n))))))
    (lambda (password salt)
      (let ((k (string->key password))
            (new-des-e (salt-des-e salt))
            (old-des-e des-e))
        (let ((c (dynamic-wind
                     (lambda ()
                       (set! des-e new-des-e))
                     (lambda ()
                       (encrypt 0 k 25))
                     (lambda ()
                       (set! des-e old-des-e)))))
          (string-append salt (key->string c)))))))