Fetching contributors…
Cannot retrieve contributors at this time
executable file 131 lines (112 sloc) 4.87 KB
#lang racket
(module+ test (require rackunit rackunit/text-ui))
;; TODO -- consider keeping this data someplace other than (or in
;; addition to) a file on disk -- like Amazon's S3. That way if I
;; want to move the bot to a new hosting site, I don't have to bring
;; the directory along with me.
(define *userinfo-database-directory-name* (make-parameter "test-userinfo.db"))
(define *sightings-to-keep* 2)
(define *messages-to-keep* 20)
;; each user has an info record that is an alist mapping a type symbol (either
;; 'sightings or 'messages) to a value. The value will be a list of sighting
;; records and a list of message values in these cases respectively, and a
;; bunch of additional information bits can hang there.
(define (canonicalize-nick n)
;; TODO -- consider nixing _leading_ underscores as well; I've seen
;; those in the wild.
;; I've forgotten why I put (?<=.) in the regexp :-(
(string-downcase (regexp-replace #rx"(?<=.)([`_]*)$" n "")))
(module+ test
(define-test-suite canonicalize-nick-tests
(check-equal? "plunderblunder" (canonicalize-nick "plunderblunder"))
(check-equal? "sam" (canonicalize-nick "sam`"))
(check-equal? "sam" (canonicalize-nick "sam_`_`"))
(define (canonical-nick->infopath n)
(let ([base (build-path (*userinfo-database-directory-name*)
(substring n 0 1))])
(unless (directory-exists? base) (make-directory* base))
(build-path base n)))
(define (info-ref nick [default #f])
(let* ([nick (canonicalize-nick nick)]
[cell (cache-lookup nick)])
(or (mcdr cell)
(let* ([infofile (canonical-nick->infopath nick)]
[info (if (file-exists? infofile)
(let ([info (with-handlers
([exn:fail:read? (lambda (e) default)])
(call-with-input-file infofile read))])
(if (list? info)
(set-mcdr! cell info)
(define (info-set! nick val)
(let* ([nick (canonicalize-nick nick)]
[infofile (canonical-nick->infopath nick)]
[cell (cache-lookup nick)])
(set-mcdr! cell val)
(call-with-output-file infofile #:exists 'truncate
(lambda (o) (write val o)))))
(define info-cache '()) ; maps nick to its info
(define info-cache-max 20)
(define (cache-lookup key)
(let loop ([n (sub1 info-cache-max)] [cache info-cache] [prev #f])
(cond [(or (null? cache) (zero? n))
;; not found, or too many: trim, and create a new entry
(when prev (set-mcdr! prev '()))
(let ([new (mcons key #f)])
(set! info-cache (mcons new info-cache))
[(equal? key (mcar (mcar cache)))
;; found: move to front if needed, and return
(when prev
(set-mcdr! prev (mcdr cache))
(set-mcdr! cache info-cache)
(set! info-cache cache))
(mcar cache)]
;; else: march on
[else (loop (sub1 n) (mcdr cache) cache)])))
;; generic setter for some property
(define (userinfo-ref nick key [default #f])
(dict-ref (info-ref nick '()) key default))
(define (userinfo-set! nick key val)
(info-set! nick (dict-set (info-ref nick '()) key val)))
;; generic list-of-values constructor for a lookup-* and note-* functions
(define (make-limited-list-info key get-nick get-time limit)
(define (trim vals) (drop vals (max 0 (- (length vals) limit))))
(define (lookup nick) (trim (userinfo-ref nick key '())))
(define (add! val)
(let* ([nick (get-nick val)]
;; lookup in db, sort, trim
[vals (userinfo-ref nick key '())]
[vals (sort (cons val vals) < #:key get-time)]
[vals (trim vals)])
(userinfo-set! nick key vals)))
(values lookup add!))
;; Some limited lists infos
(define-struct sighting (who where when action? words) #:prefab)
(define-values (lookup-sightings note-sighting)
'sightings sighting-who sighting-when *sightings-to-keep*))
(define-struct message (who from where when words) #:prefab)
(define-values (lookup-messages note-message)
'messages message-who message-when *messages-to-keep*))
(provide *userinfo-database-directory-name*)
[struct sighting ([who string?]
[where string?]
[when natural-number/c]
[action? (or/c string? not)]
[words (listof string?)])]
[lookup-sightings (-> string? (listof sighting?))]
[note-sighting (-> sighting? void?)]
[canonicalize-nick (-> string? string?)]
[userinfo-ref (->* (string? any/c) (any/c) any)]
[userinfo-set! (-> string? any/c any/c any)])
(module+ test
(define-test-suite all-tests
(run-tests all-tests))