Perform IRC-specific casemapping

1 files changed, 33 insertions, 2 deletions

diff --git a/irc/bot.rkt b/irc/bot.rkt
index a26e0df..c0d9d22 100644
--- a/irc/bot.rkt
+++ b/irc/bot.rkt
@@ -1,9 +1,31 @@
 #lang racket/base
 (require "core.rkt"
          (for-syntax racket/base racket/syntax)
+         racket/string racket/function
          racket/stxparam)
 (provide (all-defined-out))
 
+(define (replace-many s rep)
+  (foldl (λ (rep acc) (apply string-replace acc rep)) s rep))
+
+(define casemap-empty '())
+
+(define casemap-uppercase-strict-rfc1459
+  '(("{" "[") ("}" "]") ("|" "\\")))
+(define casemap-lowercase-strict-rfc1459
+  (map reverse casemap-uppercase-strict-rfc1459))
+
+(define casemap-uppercase-relaxed-rfc1459
+  (cons '("^" "~") casemap-uppercase-strict-rfc1459))
+(define casemap-lowercase-relaxed-rfc1459
+  (map reverse casemap-uppercase-relaxed-rfc1459))
+
+(define (irc-downcase s [casemap casemap-lowercase-relaxed-rfc1459])
+  (replace-many (string-downcase s) casemap))
+
+(define (irc-upcase s [casemap casemap-uppercase-relaxed-rfc1459])
+  (replace-many (string-upcase s) casemap))
+
 (define current-nick (make-parameter #f))
 
 (define (tags) (message-tags (current-message)))
@@ -13,7 +35,8 @@
 (define (suffix) (message-suffix (current-message)))
 (define (params) (message-params (current-message)))
 
-(define (source) (message-prefix-nick (current-message)))
+(define (unaltered-source) (message-prefix-nick (current-message)))
+(define (source) (irc-downcase (unaltered-source)))
 (define (target) (car (params)))
 (define (context)
   (let* ([t (target)]
@@ -48,7 +71,7 @@
 (comparison-functions context)
 
 (define (register [nick (current-nick)]
-                  #:user [user nick] #:mode [mode "*"]
+                  #:user [user nick] #:mode [mode "0"]
                   #:unused [unused "*"] #:realname [realname user]
                   #:pass [pass #f])
   (when pass (send (msg 'PASS '() pass)))
@@ -75,3 +98,11 @@
 
 (define-syntax-rule (on condition action ...)
   (hook-add (current-connection) (λ () (when condition action ...))))
+
+(define-syntax-rule (on-once condition action ...)
+  (on condition action ... hook-abort))
+
+; does this belong here?
+(define (safe-read-string s)
+  (call-with-default-reading-parameterization
+    (thunk (read (open-input-string s)))))