ccnum.rkt
#lang racket/base
;; For legal info, see file "info.rkt".

(require (planet neil/mcfly))

(doc (section "Introduction")

     (para (italic "Achtung!  Do not use this library as anything other than a
novelty unless you understand the code thoroughly and can invest in verifying
its correctness.  I will not be held liable if you say, ``Hey, "
                   (code "ccnum")
                   " says the credit card number is good!  So mail grandma's
jewelry to that nice man in Nigeria; we're rich, baby!''"))

     (para "The "
           (code "ccnum")
           " package defines a few utilities for validating and formatting
credit card numbers.  Credit card numbers are represented as strings containing
digits and arbitrary whitespace.  The procedures are based on information
gleaned from dozens of written artifacts of credit card number oral tradition.
The author invites free copies of authoritative documentation.")

     (para "Some references that were used:")

     (itemlist
      (item
       "Jeremy Scott Bradbury, ``"
       (hyperlink "http://www.cs.queensu.ca/~bradbury/checkdigit/creditcardcheck.htm"
                  "Credit Card Check Digit")
       ",'' Web page, viewed 2004-05-15.")

      (item "Michael Gilleland, ``"
            (hyperlink "http://www.merriampark.com/anatomycc.htm"
                       "Anatomy of Credit Card Numbers")
            ",'' Web page, viewed 2004-05-15.")

      (item "Happy Hippy, ``"
            (hyperlink "http://www.hippy.freeserve.co.uk/credcard.htm"
                       "Credit Card Magic")
            ",'' Web page, viewed 2004-05-15.")))

(define (%ccnum:error p m o) (error (string-append p " - " m) o))

(define (%ccnum:char-blank? c)
  (or (char-whitespace? c) (eqv? c #\-)))

(doc (section "Validation")

     (para "The following procedures provide different ways of validating
credit card numbers.  Most applications will use "
           (racket credit-card-number-check-digit-ok?)
           "  or "
           (racket credit-card-number-seems-ok?)
           "."))

(doc (defproc (check-credit-card-number (str string?))
         (or/c #f
               exact-nonnegative-integer?
               (list/c boolean?
                       exact-positive-integer?
                       (or/c 'american-express
                             'australian-bankcard
                             'carte-blanche
                             'diners-club
                             'discover-novus
                             'jcb
                             'mastercard
                             'visa)))

       (para "Performs a partial validation of the credit card number in "
             (racket str)
             ".  If the check digit is incorrect, then "
             (racket #f)
             " is yielded:")

       (racketinput
        (check-credit-card-number "4408041234567890")
        #,(racketresult #f))

       (para "If the check digit is correct, but the issuer cannot be
determined, then an integer representing the digit count is yielded:")

       (racketinput
        (check-credit-card-number "1234567890123452")
        #,(racketresult 16))

       (para "If the check digit is correct and issuer can be determined, then
a list of three elements is returned.  The first element is a boolean value for
whether or not the digit count matches what is known about how many digits the
issuer uses for this class of cards.  The second element is the digit count.
The third element is a symbol loosely identifying the issuer.  For example:")

       (racketinput
        (check-credit-card-number "5551 2121 9")
        #,(racketresult (#f 9 mastercard)))
       (racketinput
        (check-credit-card-number "4408041234567893")
        #,(racketresult (#t 16 visa)))

       (para "Note: The above particular interface for return values is for
historical reasons, and is not particularly good form.")))
(provide check-credit-card-number)
(define check-credit-card-number
  ;; TODO: Maybe programmatically build a vector-based lookup tree from the
  ;;       list-based source.
  (let ((issuer-tree
         ;; TODO: http://www.beachnet.com/~hstiles/cardtype.html claims the
         ;;       following, but it is possibly wrong on at least one other
         ;;       point, so we're not yet implementing it:
         ;;
         ;;       | CARD TYPE| Prefix| Length| algorithm|
         ;;       |----------+-------+-------+----------|
         ;;       | enRoute  | 2014  | 15    | any      |
         ;;       |          | 2149  |       |          |
         ;;
         ;;       The 15-digit JCB numbers should also get corroboration.
         (let ((american-express    '(american-express    15))
               (australian-bankcard '(australian-bankcard 16))
               (carte-blanche       '(carte-blanche       14))
               (diners-club         '(diners-club         14))
               (discover-novus      '(discover-novus      16))
               (jcb-15              '(jcb                 15))
               (jcb-16              '(jcb                 16))
               (mastercard          '(mastercard          16))
               (visa                '(visa                16 13)))
           `((1 (8 (0 (0 ,@jcb-15))))
             (2 (1 (3 (1 ,@jcb-15))))
             (3 (0 (0 ,@diners-club)
                   (1 ,@diners-club)
                   (2 ,@diners-club)
                   (3 ,@diners-club)
                   (4 ,@diners-club)
                   (5 ,@diners-club))
                (4 ,@american-express)
                (5 (2 (8 ,@jcb-16)
                      (9 ,@jcb-16))
                   (3 ,@jcb-16)
                   (4 ,@jcb-16)
                   (5 ,@jcb-16)
                   (6 ,@jcb-16)
                   (7 ,@jcb-16)
                   (8 ,@jcb-16))
                (6 ,@diners-club)
                (7 ,@american-express)
                (8 (0 ,@diners-club)
                   (1 ,@diners-club)
                   (2 ,@diners-club)
                   (3 ,@diners-club)
                   (4 ,@diners-club)
                   (5 ,@diners-club)
                   (6 ,@diners-club)
                   (7 ,@diners-club)
                   (8 ,@diners-club)
                   (9 ,@carte-blanche)))
             (4 ,@visa)
             (5 (1 ,@mastercard)
                (2 ,@mastercard)
                (3 ,@mastercard)
                (4 ,@mastercard)
                (5 ,@mastercard))
             (6 (0 (1 (1 ,@discover-novus)))
                (1 (0 ,@australian-bankcard))))))
        (issuer-tree-select
         (lambda (tree d)
           (cond ((null? tree)         tree)
                 ((symbol? (car tree)) tree)
                 (else (let ((subtree (assq d tree)))
                         (if subtree
                             (cdr subtree)
                             '())))))))
    (lambda (str)
      (let ((str-len (string-length str)))
        (let scan ((digit-count 0)
                   (even-sum    0)
                   (odd-sum     0)
                   (i           0)
                   (issuers     issuer-tree))
          (if (= i str-len)
              (if (and (not (zero? digit-count))
                       (zero? (modulo (if (even? digit-count) even-sum odd-sum)
                                      10)))
                  (let ((issuer (if (and (not (null? issuers))
                                         (symbol? (car issuers)))
                                    issuers
                                    #f)))
                    (if issuer
                        (list (if (memq digit-count (cdr issuer)) #t #f)
                              digit-count
                              (car issuer))
                        digit-count))
                  #f)
              ;; Note: Before, we were doing digit-char->integer conversion
              ;; with the following, but there's no sense requiring ASCII.
              ;;
              ;;  (let ((d (- (char->integer ) 48)))
              ;;    (cond ((<= 0 d 9)
              ;;           ...)
              ;;          ...))
              (let* ((c (string-ref str i))
                     (d (case c
                          ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4)
                          ((#\5) 5) ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9)
                          (else  #f))))
                (cond (d (let ((dd (if (< d 5) (* 2 d) (- (* 2 d) 9))))
                           (if (odd? digit-count)
                               (scan (+ digit-count      1)
                                     (+ even-sum         d)
                                     (+ odd-sum          dd)
                                     (+ i                1)
                                     (issuer-tree-select issuers d))
                               (scan (+ digit-count      1)
                                     (+ even-sum         dd)
                                     (+ odd-sum          d)
                                     (+ i                1)
                                     (issuer-tree-select issuers d)))))
                      ((%ccnum:char-blank? c)
                       (scan digit-count even-sum odd-sum (+ i 1) issuers))
                      (else #f)))))))))

(doc (defproc (credit-card-number-check-digit-ok? (str string?))
         boolean?

       (para "Predicate for whether or not the check digit of credit card
number "
             (racket str)
             " is correct.")

       (racketinput
        (credit-card-number-check-digit-ok? "4408 0412 3456 7893")
        #,(racketresult #t))
       (racketinput
        (credit-card-number-check-digit-ok? "4408 0412 3456 7890")
        #,(racketresult #f))
       (racketinput
        (credit-card-number-check-digit-ok? "trump")
        #,(racketresult #f))))
(provide credit-card-number-check-digit-ok?)
(define (credit-card-number-check-digit-ok? str)
  ;; TODO: This is a little inefficient, since we are doing computation and a
  ;;       small amount of allocation we don't need.
  (if (check-credit-card-number str) #t #f))

(doc (defproc (credit-card-number-seems-ok? (str string?))
         boolean?

       (para "Predicate for whether or not the credit card number "
             (racket str)
             " ``seems'' to be valid.  For a credit card number to ``seem''
valid, the check digit must be correct, the issuer must be identified, and the
digit count must match what is known about issuer digit counts.  In the
following example the check digit is correct, and the issuer (MasterCard) has
been identified, but the digit count is too low for a MasterCard number:")

       (racketinput
        (credit-card-number-check-digit-ok? "5551 2121 9")
        #,(racketresult #t))
       (racketinput
        (credit-card-number-seems-ok?       "5551 2121 9")
        #,(racketresult #f))))
(provide credit-card-number-seems-ok?)
(define (credit-card-number-seems-ok? str)
  (let ((data (check-credit-card-number str)))
    (cond ((not data)      #f)
          ((integer? data) #f)
          (else            (car data)))))

(doc (section "Formatting")

     (para "Two procedures are provided for formatting credit card numbers."))

(doc (defproc (write-formatted-credit-card-number (str string)
                                                  (port output-port?))
         void?

       (para "Writes credit card number "
             (racket str)
             " to output port "
             (racket port)
             ", using a format similar to that used on many credit cards.  In
the current version of this package, the format is always groups of four digits
separated by single space characters, although a future version might mimic the
format used by the issuer.  For example:")

       (racketblock
        (write-formatted-credit-card-number " 1 23 456  7890 12345 6 "
                                            (current-output-port)))

       (para "Outputs:")

       (nested #:style 'inset (racketoutput "1234 5678 9012 3456"))))
(provide write-formatted-credit-card-number)
(define (write-formatted-credit-card-number str port)
  ;; TODO: Maybe signal an error if no digits written.
  (let ((len (string-length str)))
    (let scan ((i          0)
               (pad?       #f)
               (group-left 4))
      (and (< i len)
           (let ((c (string-ref str i)))
             (cond ((char-numeric? c)
                    (and pad? (write-char #\space port))
                    (write-char c port)
                    (if (= group-left 1)
                        (scan (+ 1 i) #t 4)
                        (scan (+ 1 i) #f (- group-left 1))))
                   ((%ccnum:char-blank? c)
                    (scan (+ 1 i) pad? group-left))
                   (else (%ccnum:error
                          "write-formatted-credit-card-number"
                          "invalid character in credit card number string"
                          "c"))))))))

(doc (defproc (formatted-credit-card-number (str string?))
         string?

       (para "Yields a formatted string representation of credit card number "
             (racket str)
             " like that written by "
             (racket write-formatted-credit-card-number)
             ".")

       (racketinput
        (formatted-credit-card-number "1234567890123456")
        #,(racketresult  "1234 5678 9012 3456"))

       (racketinput
        (formatted-credit-card-number "  12 34 56  7890 1234 56")
        #,(racketresult  "1234 5678 9012 3456"))

       (racketinput
        (formatted-credit-card-number "123 abc")
        #,(racketresult #f))

       (para "Note that "
             (racket (write-formatted-credit-card-number n p))
             " might be more efficient than "
             (racket (display (formatted-credit-card-number
                               n) p))
             ".")))
(provide formatted-credit-card-number)
(define (formatted-credit-card-number str)
  (let ((len (string-length str)))
    (let scan ((i           0)
               (digit-count 0)
               (group-left  4)
               (digit-pos   0))
      (if (= i len)
          (if (zero? digit-count)
              #f
              (make-string (+ digit-count (quotient (- digit-count 1) 4))
                           #\space))
          (let ((c (string-ref str i)))
            (cond ((char-numeric? c)
                   (let ((result (if (= 1 group-left)
                                     (scan (+ 1 i)
                                           (+ 1 digit-count)
                                           4
                                           (+ 2 digit-pos))
                                     (scan (+ 1 i)
                                           (+ 1 digit-count)
                                           (- group-left 1)
                                           (+ 1 digit-pos)))))
                     (and result
                          (string-set! result digit-pos c))
                     result))
                  ((%ccnum:char-blank? c)
                   (scan (+ 1 i) digit-count group-left digit-pos))
                  (else #f)))))))

;; (define (credit-card-number-mii-digit-issuer-category int)
;;   (if (<= 0 int 9)
;;       (vector-ref
;;        '#(iso-tc-68-and-other-industry-assignments
;;           airlines
;;           airlines-and-other-industry-assignments
;;           travel-and-entertainment
;;           banking-and-financial
;;           banking-and-financial
;;           merchandizing-and-banking
;;           petroleum
;;           telecommunications-and-other-industry-assignments
;;           national-assignment)
;;        int)
;;       (%ccnum:error
;;        "credit-card-number-mii-digit-issuer-category"
;;        "invalid credit card MII digit"
;;        int)))

;; TODO: We don't permit integers to be used as a credit card number
;;       representation because apparently the first digit (the MII) could be
;;       0, which would be lost in integer representation.  This would lose
;;       information about even/odd-ness that's pertinent to the check digit
;;       calculation.  A future version of this package could conceivably
;;       support representations as lists and vectors of integers, if there is
;;       interest.

;; TODO: [Bradbury] claims ``In American Express and Discover the prefix digits
;;       are omitted from all calculations.''  I have not yet found any
;;       corroboration of this, and I found one direct refutation.  Need an
;;       authoritative source.  Also get some test cases of known valid ones.
;;
;;       "3712 321345 95006" ;; American Express sample

;; TODO: Whole Foods gift card. "6362 6400 0683 0584".

;; TODO: Add "write-credit-card-number-digits-only"
;;       and "credit-card-number-digits-only".

(doc history

     (#:planet 2:0 #:date "2012-06-14"

               "Converted to McFly and Overeasy.")

     (#:version "0.4" #:date "2009-03-11" #:planet 1:2
                (itemize
                 (item "Documentation tweaks.")))

     (#:version "0.3" #:date "2009-03-03" #:planet 1:1
                (itemize
                 (item "License is now LGPL 3.  Converted to author's new Scheme administration
system.  Tweaks for PLT 4.x.")))

     (#:version "0.2" #:date "2005-03-29" #:planet 1:0
                (itemize
                 (item "Minus characters ("
                       (racket #\-)
                       ") are now accepted as blanks in credit card numbers.")))

     (#:version "0.1" #:date "2004-05-15"
                (itemize
                 (item "First release."))))