(use test)
(use srfi-1 srfi-13)

(use crypt)

(test-begin "Chicken crypt egg")

(define-syntax test-crypt
  (syntax-rules ()
    ((_ salt pw hash)
     (test pw hash (crypt pw salt)))
    ((_ pw hash)
     (test pw hash (crypt pw hash)))))

(test-group "crypt API"
  (test-group "original UNIX DES crypt"
    ;; Basic tests with simple salts
    (test-crypt "abcdefgh" "..dCr2UJOULd6")
    (test-crypt "abcdefgh" "./GLbXuBxqD4c")
    (test-crypt "abcdefgh" "/.s4aPh2tuT.E")
    (test-crypt "abcdefgh" "//4xJaIqO2vXo")
    (test-crypt "abcdefgh" "TzvvenFb2a2vg")
    (test-crypt "abcdefgh" "zTBLo.IixVrPs")
    (test-crypt "abcdefgh" "zzcHgwjUppv8U")
    ;; From FreeBSD's libcrypt test/cert.c
    (test-crypt "ar" "foob" "arlEKn0OzVJn.")
    ;; From NetBSD's ATF tests for DES crypt
    (test-crypt "ef" "testing" "efGnQx2725bI2")
    (test-crypt "yA" "bca76;23" "yA1Rp/1hZXIJk")

    ;; From http://openwall.info/wiki/john/sample-hashes
    (test-crypt "password" "rEK1ecacw.7.c"))

  (test-group "extended UNIX DES with rounds (aka BSDi crypt)"
    ;; Test data from FreeBSD's libcrypt test/cert.c
    (test-crypt "_X......." "holyhooplasbatman!"     "_X.......N89y2Z.e4WU")
    (test-crypt "_X...X..." "holyhooplasbatman!"     "_X...X...rSUDQ5Na/QM")
    (test-crypt "_XX..X..." "holyhooplasbatman!"     "_XX..X...P8vb9xU4JAk")
    (test-crypt "_XX..XX.." "holyhooplasbatman!"     "_XX..XX..JDs5IlGLqT2")
    (test-crypt "_XX..XXa." "holyhooplasbatman!"     "_XX..XXa.bFVsOnCNh8Y")
    (test-crypt "_XXa.X..." "holyhooplasbatman!"     "_XXa.X...Ghsb3QKNaps")
    ;; Too slow on most implementations
                                        ;(test-crypt "_arararar" "_ararararNGMzvpNjeCc"     "holyhooplasbatman!")

    ;; Test data from http://openwall.info/wiki/john/sample-hashes
    (test-crypt "password" "_J9..K0AyUubDrfOgO4s"))

  (test-group "MD5 crypt (Phk's 1000-round MD5 from FreeBSD)"
    ;; Test data from
    ;; http://code.activestate.com/recipes/325204-passwd-file-compatible-1-md5-crypt
    (test-crypt "$1$yiiZbNIH"
                " "
                "$1$yiiZbNIH$YiCsHZjcTkYd31wkgW8JF.")
    (test-crypt " "
                "$1$yiiZbNIH$YiCsHZjcTkYd31wkgW8JF.")
    (test-crypt "pass"
                "$1$YeNsbWdH$wvOF8JdqsoiLix754LTW90")
    (test-crypt "____fifteen____"
                "$1$s9lUWACI$Kk1jtIVVdmT01p0z3b/hw1")
    (test-crypt "____sixteen_____"
                "$1$dL3xbVZI$kkgqhCanLdxODGq14g/tW1")
    (test-crypt "____seventeen____"
                "$1$NaH5na7J$j7y8Iss0hcRbu3kzoJs5V.")
    (test-crypt "__________thirty-three___________"
                "$1$HO7Q6vzJ$yGwp2wbL5D7eOVzOmxpsy.")
    ;; Currently, Apache-style MD5 is not supported (we would be forced to use
    ;; our own MD5 even if the system crypt() had an MD5 implementation)
    #;(test-crypt "apache" "$apr1$J.w5a/..$IW9y6DR0oO/ADuhlMF5/X1")
    ;; Generated with Apache's htpasswd
    #;(test-crypt "123" "$apr1$NrBSM7Jv$soJsh7lPdJUdmF3PzPJxw/")
    ;; Test data from http://openwall.info/wiki/john/sample-hashes
    (test-crypt "password" "$1$O3JMY.Tw$AdLnLjQ/5jXF9.MTp3gHv/"))

  ;; Generated SHA1 with htpasswd: "{SHA}qZk+NkcGgWq6PiVxeFDCbJzQ2J0=" for 'abc'
  ;; SHA1 with pwhash: "$sha1$10$V7hofx/G$DkKAzSeu2510ZVcharKl1dtkl6og"
  ;; Same, 12 rounds:  "$sha1$12$yRrPIIdx$1zWhpmyLrc6WyRTvE/tgLQZyquYX"

  (test-group "Provos & Mazières' Blowfish scheme (aka bcrypt())"
    ;; Test data from OpenWall's bcrypt
    (test-crypt "$2a$05$CCCCCCCCCCCCCCCCCCCCC."
                "U*U"
                "$2a$05$CCCCCCCCCCCCCCCCCCCCC.E5YPO9kmyuRGyh0XouQYb4YMJKvyOeW")
    (test-crypt "U*U"
                "$2a$05$CCCCCCCCCCCCCCCCCCCCC.E5YPO9kmyuRGyh0XouQYb4YMJKvyOeW")
    (test-crypt "U*U*"
                "$2a$05$CCCCCCCCCCCCCCCCCCCCC.VGOzA784oUp/Z0DY336zx7pLYAy0lwK")
    (test-crypt "U*U*U"
                "$2a$05$XXXXXXXXXXXXXXXXXXXXXOAcXxm9kjPGEMsLznoKqmqw7tc8WCx4a")
    (test-crypt (conc "0123456789abcdefghijklmnopqrstuvwxyz"
                      "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789")
                "$2a$05$abcdefghijklmnopqrstuu5s2v8.iXieOjg/.AySBTTZIIVFJeBui")

    ;; From http://openwall.info/wiki/john/sample-hashes
    (test-crypt "password"
                "$2a$05$bvIG6Nmid91Mu9RcmmWZfO5HJIMCT8riNW0hEp8f6/FuA2/mHZFpe"))

  (test-group "Ulrich Drepper's SHA-2 crypt"
    (test-group "SHA-256"
      ;; From the specification
      (test-crypt "$5$saltstring"
                  "Hello world!"
                  "$5$saltstring$5B8vYYiY.CVt1RlTTf8KbXBH3hsxY/GNooZaBBGWEc5")
      (test-crypt "$5$rounds=10000$saltstringsaltstring"
                  "Hello world!"
                  (conc "$5$rounds=10000$saltstringsaltst$"
                        "3xv.VbSHBb41AL9AvLeujZkZRBAwqFMz2.opqey6IcA") )
      (test-crypt "$5$rounds=5000$toolongsaltstring"
                  "This is just a test"
                  (conc "$5$rounds=5000$toolongsaltstrin$"
                        "Un/5jzAHMgOGZ5.mWJpuVolil07guHPvOW8mGRcvxa5"))
      (test-crypt "$5$rounds=1400$anotherlongsaltstring"
                  (conc "a very much longer text to encrypt.  This one even "
                        "stretches over morethan one line.")
                  (conc "$5$rounds=1400$anotherlongsalts$"
                        "Rx.j8H.h8HjEDGomFU8bDkXm3XIUnzyxf12oP84Bnq1"))
      (test-crypt "$5$rounds=77777$short"
                  "we have a short salt string but not a short password"
                  (conc "$5$rounds=77777$short$"
                        "JiO1O3ZpDAxGJeaDIuqCoEFysAe1mZNJRs3pw0KQRd/"))
      (test-crypt "$5$rounds=123456$asaltof16chars.."
                  "a short string"
                  (conc "$5$rounds=123456$asaltof16chars..$"
                        "gP3VQ/6X7UUEW3HkBn2w1/Ptq2jxPyzV/cZKmF/wJvD"))
      (test-crypt "$5$rounds=10$roundstoolow"
                  "the minimum number is still observed"
                  (conc "$5$rounds=1000$roundstoolow$"
                        "yfvwcWrQ8l/K0DAWyuPMDNHpIVlTQebY9l/gL972bIC"))
      ;; From http://openwall.info/wiki/john/sample-hashes
      (test-crypt "password"
                  "$5$MnfsQ4iN$ZMTppKN16y/tIsUYs/obHlhdP.Os80yXhTurpBMUbA5"))
  
    (test-group "SHA-512"
      ;; From the specification
      (test-crypt "$6$saltstring"
                  "Hello world!"
                  (conc "$6$saltstring$svn8UoSVapNtMuq1ukKS4tPQd8iKwSMHWjl/"
                        "O817G3uBnIFNjnQJu"
                        "esI68u4OTLiBFdcbYEdFCoEOfaS35inz1"))
      (test-crypt "$6$rounds=10000$saltstringsaltstring"
                  "Hello world!"
                  (conc "$6$rounds=10000$saltstringsaltst$"
                        "OW1/O6BYHV6BcXZu8QVeXbDWra3Oeqh0sb"
                        "HbbMCVNSnCM/UrjmM0Dp8vOuZeHBy/YTBmSK6H9qs/y3RnOaw5v."))
      (test-crypt "$6$rounds=5000$toolongsaltstring"
                  "This is just a test"
                  (conc "$6$rounds=5000$toolongsaltstrin$"
                        "lQ8jolhgVRVhY4b5pZKaysCLi0QBxGoNeKQ"
                        "zQ3glMhwllF7oGDZxUhx1yxdYcz/e1JSbq3y6JMxxl8audkUEm0"))
      (test-crypt "$6$rounds=1400$anotherlongsaltstring"
                  (conc "a very much longer text to encrypt.  This one even "
                        "stretches over morethan one line.")
                  (conc "$6$rounds=1400$anotherlongsalts$"
                        "POfYwTEok97VWcjxIiSOjiykti.o/pQs.wP"
                        "vMxQ6Fm7I6IoYN3CmLs66x9t0oSwbtEW7o7UmJEiDwGqd8p4ur1"))
      (test-crypt "$6$rounds=77777$short"
                  "we have a short salt string but not a short password"
                  (conc "$6$rounds=77777$short$WuQyW2YR.hBNpjjRhpYD/"
                        "ifIw05xdfeEyQoMxIXbkvr0g"
                        "ge1a1x3yRULJ5CCaUeOxFmtlcGZelFl5CxtgfiAc0"))
      (test-crypt "$6$rounds=123456$asaltof16chars.."
                  "a short string"
                  (conc "$6$rounds=123456$asaltof16chars..$"
                        "BtCwjqMJGx5hrJhZywWvt0RLE8uZ4oPwc"
                        "elCjmw2kSYu.Ec6ycULevoBK25fs2xXgMNrCzIMVcgEJAstJeonj1"))
      (test-crypt "$6$rounds=10$roundstoolow"
                  "the minimum number is still observed"
                  (conc "$6$rounds=1000$roundstoolow$kUMsbe306n21p9R."
                        "FRkW3IGn.S9NPN0x50YhH1x"
                        "hLsPuWGsUSklZt58jaTfF4ZEQpyUNGc0dqbpBYYBaHHrsX."))

      ;; From http://openwall.info/wiki/john/sample-hashes
      (test-crypt "password"
                  (conc "$6$zWwwXKNj$gLAOoZCjcr8p/.VgV/"
                        "FkGC3NX7BsXys3KHYePfuIGMNjY83dVxugPYlxVg/"
                        "evpcVEJLT/rSwZcDMlVVf/bhf.1")))))

;; These tests are tightly coupled to the actual implementation of the
;; salt generation code.  The tests just guard against regressions.
;;
;; TODO: Add tests for the gensalt wrapper to ensure it's calling all the
;; gensalt procedures correctly (possible with parameterize?)
(test-group "gensalt API"
  (test "DES" "AE"
        (let ((v (u8vector #b00110001)))
          (crypt-des-gensalt (constantly v))))
  (test "extended DES 58 rounds" "_u...ABCD"
        (let ((v (u8vector #b00110000 #b11010011 #b10001111)))
          (crypt-des-extended-gensalt (constantly v) rounds: 58)))
  (test "extended DES 1 round" "_/...ABCD"
        (let ((v (u8vector #b00110000 #b11010011 #b10001111)))
          (crypt-des-extended-gensalt (constantly v) rounds: 1)))
  (test "extended DES 128 rounds" "_./..ABCD"
        (let ((v (u8vector #b00110000 #b11010011 #b10001111)))
          (crypt-des-extended-gensalt (constantly v) rounds: 64)))
  (test "MD5" "$1$........"
        (crypt-md5-gensalt (constantly (make-u8vector 6 0))))
  (test "MD5 nonzero" "$1$ABCDEFGH"
        (let ((v (u8vector #b00110000 #b11010011 #b10001111
                           #b01000001 #b00010100 #b10010011)))
          (crypt-md5-gensalt (constantly v))))
  (test "blowfish" "$2a$14$......................"
        (crypt-blowfish-gensalt (constantly (make-u8vector 16 0)) rounds: 14))
  (test "blowfish nonzero" "$2a$13$Zabcdefghijklmnopqrstu"
        ;; The blowfish code reads bits left-to-right.  Once a word is
        ;; consumed, the MSB from the next word is read next.
        (let ((v (u8vector #b01101101 #b11000111 #b01011110 #b01111110
                           #b00001000 #b01100010 #b10001110 #b01001001
                           #b01100110 #b10011110 #b10001010 #b01101010
                           #b10101110 #b11001011 #b01101110 #b10111111
                           ;; ^ 128 bits; the string is 132 bits, so the
                           ;; final four bits are implicitly always zero.
                           ;; The algorithm will only use these 128 bits.
                           )))
          (crypt-blowfish-gensalt (constantly v) rounds: 13)))
  (test-group "SHA-2"
    (test "Smallest SHA-256" "$5$ABCDEE"
          (let ((v (u8vector #b00110000 #b11010011 #b10001111 #b01000001)))
            (crypt-sha256-gensalt (constantly v))))
    (test "Largest SHA-256" "$5$ABCDEFGHIJKLMNOP"
          (let ((v (u8vector #b00110000 #b11010011 #b10001111
                             #b01000001 #b00010100 #b10010011
                             #b01010001 #b01010101 #b10010111
                             #b01100001 #b10010110 #b10011011)))
            (crypt-sha256-gensalt (constantly v) rounds: 5000)))
    (test "SHA-256 with nonstandard rounds" "$5$rounds=10000$ABCDEFGHIJKL"
          (let ((v (u8vector #b00110000 #b11010011 #b10001111
                             #b01000001 #b00010100 #b10010011
                             #b01010001 #b01010101 #b10010111)))
            (crypt-sha256-gensalt (constantly v) rounds: 10000)))
    (test "Smallest SHA-512" "$6$ABCDEE"
          (let ((v (u8vector #b00110000 #b11010011 #b10001111 #b01000001)))
            (crypt-sha512-gensalt (constantly v))))
    (test "Largest SHA-512" "$6$ABCDEFGHIJKLMNOP"
          (let ((v (u8vector #b00110000 #b11010011 #b10001111
                             #b01000001 #b00010100 #b10010011
                             #b01010001 #b01010101 #b10010111
                             #b01100001 #b10010110 #b10011011)))
            (crypt-sha512-gensalt (constantly v) rounds: 5000)))
    (test "SHA-512 with nonstandard rounds" "$6$rounds=10000$ABCDEFGHIJKL"
          (let ((v (u8vector #b00110000 #b11010011 #b10001111
                             #b01000001 #b00010100 #b10010011
                             #b01010001 #b01010101 #b10010111)))
            (crypt-sha512-gensalt (constantly v) rounds: 10000)))))

(test-end)
(unless (zero? (test-failure-count)) (exit 1))