;;
;; crypt - A Scheme API to the UNIX crypt() functionality.
;;
;; This will use the built-in crypt() function provided by the OS whenever
;; possible, but includes fallback code for missing implementations.
;;
;; All Scheme code in this egg is hereby placed in the Public Domain
;;

;; TODO: Perhaps a more Schemely API?  Returning a string and requiring
;; the user to compare it with the original input is just silly.
;; Also the conflation of password hash creation and password checking
;; in one function bothers me.

(module crypt
  (crypt crypt-gensalt crypt-prefix->type crypt-maximum-random-u8vector
   crypt-default-random-u8vector crypt-default-implementation

   crypt-des-gensalt crypt-des-extended-gensalt
   crypt-des-extended-default-rounds crypt-md5-gensalt
   crypt-blowfish-gensalt crypt-blowfish-default-logrounds
   crypt-sha256-gensalt crypt-sha256-default-rounds
   crypt-sha512-gensalt crypt-sha512-default-rounds)

(import chicken scheme foreign)
(use srfi-4 srfi-13 data-structures extras)

(foreign-declare "#include \"common.c\"")

(define int->a64
  (foreign-lambda* char ((int i)) "C_return(_crypt_itoa64[i&0x3f]);"))

;; Gensalts are always loaded
(include "implementations/blowfish/gensalt.scm")
(include "implementations/SHA-2/gensalt-sha256.scm")
(include "implementations/SHA-2/gensalt-sha512.scm")
(include "implementations/MD5/gensalt.scm")
(include "implementations/DES/gensalt-extended.scm")
(include "implementations/DES/gensalt.scm")

(cond-expand
 (has-native-crypt (include "implementations/native/crypt.scm"))
 (else))

(define-syntax (fallback-implementation e r c)
  (let* ((type (symbol->string (cadr e)))
         (file (caddr e))
         (feature (string->symbol (conc "crypt-native-" type))))
   `(cond-expand ((not ,feature) (include ,file)) (else))))

(fallback-implementation blowfish "implementations/blowfish/crypt.scm")
(fallback-implementation sha512 "implementations/SHA-2/crypt-sha512.scm")
(fallback-implementation sha256 "implementations/SHA-2/crypt-sha256.scm")
(fallback-implementation md5 "implementations/MD5/crypt.scm")
(fallback-implementation des-extended "implementations/DES/crypt-extended.scm")
(fallback-implementation des "implementations/DES/crypt.scm")

(define (u8vector->saltstring u8vector)
  (let* ((salt-length (inexact->exact
                       (ceiling (/ (* (u8vector-length u8vector) 8) 6))))
         (salt (make-string salt-length)))
    ((foreign-lambda void "bytes_to_saltstring"
                     u8vector unsigned-int scheme-pointer unsigned-int)
     u8vector (u8vector-length u8vector) salt salt-length)
    salt))

(define (get-random-u8vector impl random minimum-size maximum-size)
  (let* ((input (random minimum-size maximum-size))
         (input-size (u8vector-length input)))
    (cond
     ((fx< input-size minimum-size)
      (error "Vector with random bytes too short" impl input-size minimum-size))
     ((fx> input-size (or maximum-size input-size))
      (error "Vector with random bytes too long" impl input-size maximum-size))
     (else input))))

(define (crypt-maximum-random-u8vector minimum-size maximum-size)
  (let ((size (or maximum-size minimum-size)))
    (do ((i 0 (fx+ i 1))
         (v (make-u8vector size)))
        ((fx= i size) v)
      (u8vector-set! v i (random 256)))))

(define crypt-default-random-u8vector
  (make-parameter crypt-maximum-random-u8vector))

(define crypt-default-implementation (make-parameter 'blowfish))

;; Maybe this should be sped up (by not comparing from the start every time)
(define (crypt-prefix->type str)
  (cond ((string-prefix? "_" str) 'des-extended)
        ((not (string-prefix? "$" str)) 'des)
        ((string-prefix? "$2a$" str) 'blowfish)
        ((string-prefix? "$6$" str) 'sha512)
        ((string-prefix? "$5$" str) 'sha256)
        ((string-prefix? "$1$" str) 'md5)
        ((string-prefix? "$sha1$" str) 'sha1)
        ;; These are just stupid
        ((string-prefix? "$apr1$" str) 'md5-apr)
        ((string-prefix? "{SHA}" str) 'sha1-apr)
        ((string-prefix? "$P$" str) 'phpass)
        ((string-prefix? "$H$" str) 'phpass-bbforum)
        ;; The following two are not supported (and probably never will be)
        ;; but they are here for completeness.  NTLM doesn't use salts(!)
        ;; and the old-style blowfish is not documented or even *used*, AFAIK
        ((or (string-prefix? "$NT$" str) (string-prefix? "$3$$" str)) 'ntlm)
        ((string-prefix? "$2$" str) 'blowfish-deprecated)
        ;; What about OS X? Apparently it doesn't use a prefix at all
        ;; for its SHA-1 salted hashes.. :(  But then again, maybe that
        ;; disqualifies it from being Unix crypt
        (else (error "Unknown crypt prefix type" str))))

(define-syntax (crypt-cases e r c)
  `(case ,(cadr e)
     ,@(map
        (lambda (type)
          (let* ((fallback-procedure (string->symbol (conc "crypt-" type)))
                 (feature-name (string->symbol (conc "crypt-native-" type))))
            `((,type)
              (cond-expand (,feature-name (crypt-native password hash))
                           (else (,fallback-procedure password hash))))))
        (cddr e))
     (else (error "Unkown crypt() type" ,(cadr e)))))

(define (crypt password #!optional setting)
  (let* ((type (if setting
                   (crypt-prefix->type setting)
                   (crypt-default-implementation)))
         (hash (or setting (crypt-gensalt type: type))))
    (crypt-cases type
      blowfish sha512 sha256 md5 #;sha1 md5 des-extended des)))

(define (crypt-gensalt #!key type random)
  (let ((random (or random (crypt-default-random-u8vector))))
   (case (or type (crypt-default-implementation))
     ((blowfish) (crypt-blowfish-gensalt random))
     ((sha512) (crypt-sha512-gensalt random))
     ((sha256) (crypt-sha256-gensalt random))
     ;((sha1) (crypt-sha1-gensalt random))
     ((md5) (crypt-md5-gensalt random))
     ((des-extended) (crypt-des-extended-gensalt random))
     ((des) (crypt-des-gensalt random))
     (else (error "Unsupported crypt() type" type)))))

)