+(defun dns-cache-records (cache records)
+ (loop (unless records (return))
+ (let* ((key (domain-cache-key-rr (car records)))
+ (matching (remove key records :test-not 'equal :key #'domain-cache-key-rr))
+ (ttl (block no-expire
+ (+ (/ (get-internal-real-time) internal-time-units-per-second)
+ (apply 'min (mapcar #'(lambda (rr)
+ (with-slots (ttl) rr
+ (if ttl ttl (return-from no-expire nil))))
+ matching)))))
+ (entry (make-domain-cache-entry :expire ttl :records matching)))
+ (setf (gethash key cache) entry
+ records (set-difference records matching)))))
+
+(defun dns-cache-response (cache packet)
+ (let ((records (append (dns-packet-answers packet)
+ (dns-packet-authority packet)
+ (dns-packet-additional packet))))
+ (flet ((on-root (rr)
+ (equal (slot-value rr 'name) '())))
+ (when (some #'on-root records)
+ (warn "DNS packet purports to contain RRs on the root zone.")
+ (setf records (delete-if #'on-root records))))
+ (when (dns-packet-authoritative packet)
+ (dolist (rq (dns-packet-queries packet))
+ (with-slots (name type) rq
+ (unless (equal name '())
+ (let ((key (domain-cache-key name type)))
+ (unless (find key records :test 'equal :key #'domain-cache-key-rr)
+ (let ((entry (domain-cache-get-entry cache name type :clear)))
+ (setf (domain-cache-entry-expire entry)
+ (+ (/ (get-internal-real-time) internal-time-units-per-second)
+ 60))))))))) ; XXX: Or something. It needs
+ ; to last for the query in
+ ; progress, at least. One
+ ; should probably look at an
+ ; SOA RR, if there is one.
+ (dns-cache-records cache records)))
+