;;;;;; Email address crippler                            -*- Scheme -*-
;;;;;; Munging email addresses so as not to be found by spammers

;;; Taylor Campbell wrote this code; he places it in the public domain.

;;; This depends on Taylor Campbell's string-replace.scm, a library for
;;; multiple parallel string replacements, which in turn depends on his
;;; string-collector.scm, a library for collecting strings.

;;; Note: This file does *not* contain Scheme code.  It contains code
;;; in the Scheme48 configuration language; load it into the config
;;; package of scsh.  (It depends on some scsh stuff, too.)  I may at
;;; some point make this code more portable.

(define-interface crippling-addresses-interface
  (export cripple-address
          char-encode-string
          char-encode-string/element
          punctuate-email-address))

(define-structure crippling-addresses crippling-addresses-interface
  (open scheme-with-scsh
        let-opt
        char-set-lib

        ;; Simpler than regexps.  (STRING-REPLACING corresponds with
        ;; string-replace.scm.)
        string-replacing

        ;; This could use SRFI 6, but, since STRING-REPLACING already
        ;; requires that the string collector library be loaded, and
        ;; this removes an extra dependency, we might as well use this.
        ;; (STRING-COLLECTORS is in string-collector.scm.)
        string-collectors)

  (optimize auto-integrate)

  (begin

    ;;; (CHAR-ENCODE-STRING <string> <char-set> <left-pad> <right-pad>)
    ;;;   Encodes each character in STRING as an SGML character entity
    ;;;   reference if it's in CHAR-SET, and surrounds each character,
    ;;;   regardless of whether or not it gets encoded, with LEFT-PAD
    ;;;   and RIGHT-PAD.
    (define (char-encode-string s cset left-pad right-pad)
      (let ((collector (make-string-collector)))
        (let* ((emit (lambda (ch)
                       (cond ((char-set-contains? cset ch)
                              (collect-string! collector "&#")
                              (collect-string! collector
                                               (number->string
                                                (char->ascii ch)
                                                10))
                              (collect-char! collector #\;))
                             (else
                              (collect-char! collector ch)))))
               (emit (cond ((and left-pad right-pad)
                            (lambda (ch)
                              (collect-string! collector left-pad)
                              (emit ch)
                              (collect-string! collector right-pad)))
                           (left-pad
                            (lambda (ch)
                              (collect-string! collector left-pad)
                              (emit ch)))
                           (right-pad
                            (lambda (ch)
                              (emit ch)
                              (collect-string! collector right-pad)))
                           (else emit)))
               (len (string-length s)))
          (do ((i 0 (+ i 1)))
              ((= i len)
               (string-collector->string collector))
            (emit (string-ref s i))))))

    ;;; Convenience for wrapping it in an SGML element.
    (define (char-encode-string/element s cset tag)
      (char-encode-string s cset
                          (string-append "<"  tag ">")
                          (string-append "</" tag ">")))

    ;;; (PUNCTUATE-EMAIL-ADDRESS <address>
    ;;;     [<new-at> <new-dot> <old-at> <old-dot>]) -> string
    ;;;   Replaces the at-signs and dots in an email address.
    (define (punctuate-email-address address . args)
      (let-optionals args ((new-at " (at) ")
                           (new-dot " (dot) ")
                           (old-at "@")
                           (old-dot "."))
        (strings-replace address
                         (list (cons old-at  new-at)
                               (cons old-dot new-dot))
                         char=?)))      ; Should this be CHAR-CI=? ?

    ;;; (CRIPPLE-ADDRESS <address> <char-tag> <punctuation-tag>)
    ;;;       -> string
    ;;;   Does all the crippling: CRIPPLE-ADDRESS
    ;;;     - encodes ADDRESS into SGML character references;
    ;;;     - surrounds each character with CHAR-TAG SGML elements;
    ;;;     - cripples the punctuation of the address; and
    ;;;     - surrounds the crippled punctuation with PUNCTUATION-TAG
    ;;;       SGML elements.
    (define (cripple-address address char-tag punctuation-tag)
      (punctuate-email-address
       (char-encode-string/element (punctuate-email-address address)
                                   char-set:ascii    ; ...
                                   char-tag)
       ;; New at & dot: surround them in a punctuation element.
       (string-append " <" punctuation-tag ">"
                      (char-encode-string/element "(at)"
                                                  char-set:ascii
                                                  char-tag)
                      "</" punctuation-tag "> ")
       (string-append " <" punctuation-tag ">"
                      (char-encode-string/element "(dot)"
                                                  char-set:ascii
                                                  char-tag)
                      "</" punctuation-tag "> ")
       ;; Old at & dot: they're surrounded in the regular character
       ;; element.
       (char-encode-string/element " (at) "
                                   char-set:ascii char-tag)
       (char-encode-string/element " (dot) "
                                   char-set:ascii char-tag)))

)) ; (define-structure crippling-addresses