A simple script for sending out secret santa emails.

secret-santa.lisp

(ql:quickload "mel-base")

(defparameter *debugp* t)
(defvar *purchasers* ()
  "A list of lists in the format (name email exclusion-list historical-results)")

(define-condition bad-match (condition)
  ())

(defun secret-santa (historical-exclusion-function &rest purchasers)
  (let ((recipients (mapcar #'car purchasers)))
    (handler-case 
        (mapcar (lambda (purchaser-struct)
                  (destructuring-bind (purchaser email exclusion-list historical-recipients)
                                      purchaser-struct
                    (declare (ignore email))
                    (let ((recipient (if (> (length recipients) 1)
                                       (loop for recipient = (nth (random (length recipients))
                                                                  recipients)
                                         when (not (or (eql recipient purchaser)
                                                       (find recipient exclusion-list)
                                                       (funcall historical-exclusion-function
                                                                recipient historical-recipients)))
                                         return recipient)
                                       (car recipients))))
                      (when (or (eql recipient purchaser)
                                (find recipient exclusion-list)
                                (funcall historical-exclusion-function
                                         recipient historical-recipients))
                        (signal 'bad-match))
                      (setf recipients (remove recipient recipients))
                      (cons purchaser recipient))))
                purchasers)
      (bad-match () (apply #'secret-santa historical-exclusion-function purchasers)))))

(defun exclude-none (recipient historical-list)
  (declare (ignore recipient historical-list))
  nil)

(defun exclude-last-year (recipient historical-list)
  (eql recipient (first historical-list)))

(defun exclude-all (recipient historical-list)
  (find recipient historical-list))

(defun persistent-secret-santa (historical-exclusion-function)
  (let ((mapping (apply #'secret-santa historical-exclusion-function *purchasers*)))
    (mapc (lambda (pair)
            (let ((record (assoc (car pair) *purchasers*)))
              (push (cdr pair) (fourth record))))
          mapping)
    mapping))

(defun send-message (smtp-account from-address to-address purchaser recipient)
  (mel:copy-message (mel:make-message :subject "Pfeil brothers secret santa assignment"
                                      :from from-address
                                      :to (if *debugp* from-address to-address)
                                      :body (format nil
                                                    "This year, you (~a) are buying a gift for ~a."
                                                    purchaser
                                                    recipient))
                    smtp-account))

(defun send-secret-santa (smtp-account from-address historical-exclusion-function)
  (let ((mapping (persistent-secret-santa historical-exclusion-function)))
    (mapc (lambda (pair)
            (let ((record (assoc (car pair) *purchasers*)))
              (send-message smtp-account from-address
                            (second record) (first record) (cdr pair))))
          mapping))
  (values))