Initial commit

3 files changed, 258 insertions, 0 deletions

diff --git a/irc/bot.rkt b/irc/bot.rkt
new file mode 100644
index 0000000..a26e0df
--- /dev/null
+++ b/irc/bot.rkt
@@ -0,0 +1,77 @@
+#lang racket/base
+(require "core.rkt"
+         (for-syntax racket/base racket/syntax)
+         racket/stxparam)
+(provide (all-defined-out))
+
+(define current-nick (make-parameter #f))
+
+(define (tags) (message-tags (current-message)))
+(define (prefix) (message-prefix (current-message)))
+(define (command) (message-command (current-message)))
+(define (args) (message-args (current-message)))
+(define (suffix) (message-suffix (current-message)))
+(define (params) (message-params (current-message)))
+
+(define (source) (message-prefix-nick (current-message)))
+(define (target) (car (params)))
+(define (context)
+  (let* ([t (target)]
+         [is-channel (memv (string-ref t 0) '(#\# #\& #\+))])
+    (if is-channel t (source))))
+
+(define-syntax-parameter it
+  (λ (stx) (raise-syntax-error 'it "Use of the \"it\" identifier is not allowed here" stx)))
+(define-syntax (comparison-functions stx)
+  (syntax-case stx ()
+    [(_ name)
+     (with-syntax ([name-is (format-id stx "~a-is" #'name)]
+                 [name-match (format-id stx "~a-match" #'name)])
+      #'(begin
+          (define (name-is expected)
+            (let ([actual (name)])
+            (and actual (equal? actual expected))))
+          (define-syntax-rule (name-match test)
+            (let ([actual (name)])
+              (and actual 
+                (syntax-parameterize ([it (make-rename-transformer #'actual)])
+                  test))))))]))
+
+(comparison-functions tags)
+(comparison-functions prefix)
+(comparison-functions command)
+(comparison-functions args)
+(comparison-functions suffix)
+(comparison-functions params)
+(comparison-functions source)
+(comparison-functions target)
+(comparison-functions context)
+
+(define (register [nick (current-nick)]
+                  #:user [user nick] #:mode [mode "*"]
+                  #:unused [unused "*"] #:realname [realname user]
+                  #:pass [pass #f])
+  (when pass (send (msg 'PASS '() pass)))
+  (send (msg 'USER (list user mode unused) realname))
+  (send (msg 'NICK '() nick)))
+
+(define (join . chans)
+  (send (msg 'JOIN chans #f)))
+
+(define (quit reason)
+  (send (msg 'QUIT '() reason)))
+
+(define (privmsg to content)
+  (send (msg 'PRIVMSG (list to) content)))
+
+(define (notice to content)
+  (send (msg 'NOTICE (list to) content)))
+
+(define (reply content)
+  (privmsg (context) content))
+
+(define (reply-notice content)
+  (notice (context) content))
+
+(define-syntax-rule (on condition action ...)
+  (hook-add (current-connection) (λ () (when condition action ...))))
diff --git a/irc/core.rkt b/irc/core.rkt
new file mode 100644
index 0000000..fa5edce
--- /dev/null
+++ b/irc/core.rkt
@@ -0,0 +1,128 @@
+#lang racket/base
+(require (for-syntax racket/provide) racket/provide
+         racket/string
+         racket/function racket/promise racket/exn
+         racket/tcp openssl
+         (only-in srfi/13 string-index string-index-right))
+(provide current-connection current-message current-hook-fail-handler
+         connect hook-add hook-process
+         msg send listen
+         (matching-identifiers-out #rx"^message-" (all-defined-out)))
+
+(define-logger irc)
+
+(define current-connection (make-parameter #f))
+(define current-message (make-parameter #f))
+
+(define current-hook-fail-handler
+  (make-parameter (λ (x) (displayln (exn->string x)))))
+
+(struct connection
+  (input output hooks output-lock)
+  #:mutable)
+
+(struct message
+  (tags prefix command args suffix)
+  #:methods gen:custom-write
+  [(define (write-proc msg port mode)
+     (msg-print-raw msg port))])
+
+(define (connect host port #:ssl (ssl #f))
+  (define-values (i o) ((if ssl ssl-connect tcp-connect) host port))
+  (connection i o '() (make-semaphore 1)))
+
+(define (hook-add conn fn)
+  (set-connection-hooks! conn (cons fn (connection-hooks conn))))
+
+(define (hook-process msg)
+  (with-handlers ([exn:fail? (current-hook-fail-handler)])
+    (parameterize ([current-message msg])
+      (for-each (λ (h) (h)) (connection-hooks (current-connection))))))
+
+(define (msg-print-raw msg out)
+  (define (clean s)
+    (string-replace s #rx"[\r\n]" ""))
+
+  (let ([tags (force (message-tags msg))]
+        [prefix (message-prefix msg)]
+        [cmd (message-command msg)]
+        [args (message-args msg)]
+        [suff (message-suffix msg)])
+    ; (when tags (fprintf out "@~A " tags))
+    ; (if tags
+    ;   (map (λ (t) (map clean t)) tags)
+    ;   tags)
+
+    (when prefix (fprintf out ":~A " (clean prefix)))
+    (fprintf out "~A" (clean (symbol->string cmd)))
+    (when (pair? args)
+      (fprintf out " ~A" (string-join (map clean args))))
+    (when suff (fprintf out " :~A" (clean suff)))))
+
+(define (msg-parse src)
+  (define (parse-tags tags)
+    (define (parse-tag tag)
+      (let ((eq-index (string-index tag #\=)))
+        (if eq-index
+          (list* (substring tag 0 eq-index) (substring tag (add1 eq-index)))
+          (list* tag '()))))
+    (map parse-tag (string-split (substring tags 1) ";")))
+
+  (define-values (tags prefix command args suffix) (values #f #f #f '() #f))
+  (define len (string-length src))
+
+  (do ([left 0 (add1 right)]
+       [right 0]
+       [curr #f])
+      ((= right len))
+    (set! right (or (string-index src #\space left len) len))
+    (set! curr (string-ref src left))
+
+    (cond [(char=? #\@ curr)
+           (set! tags (delay (parse-tags (substring src left right))))]
+          [(char=? #\: curr)
+           (if (or prefix command)
+             (begin (set! suffix (substring src (min len (add1 left)) len))
+                    (set! right len))
+             (set! prefix (substring src (add1 left) right)))]
+          [(not command) (set! command (substring src left right))]
+          [else (set! args (cons (substring src left right) args))]))
+
+  (message tags prefix (string->symbol command) (reverse args) suffix))
+
+(define (message-params msg) (append (message-args msg) (message-suffix msg)))
+
+(define (message-prefix-nick msg)
+  (let* ([prefix (message-prefix msg)]
+         [bang (string-index prefix #\!)])
+    (substring prefix 0 bang)))
+
+(define (message-prefix-user msg)
+  (let* ((prefix (message-prefix msg))
+         (bang (string-index prefix #\!))
+         (at (string-index-right prefix #\@)))
+    (substring prefix bang at)))
+
+(define (message-prefix-host msg)
+  (let* ((prefix (message-prefix msg))
+         (at (string-index-right prefix #\@)))
+    (substring prefix at)))
+
+(define (msg cmd args suffix #:tags (tags #f) #:prefix (prefix #f))
+  (message tags prefix cmd args suffix))
+
+(define (send msg #:conn [conn (current-connection)])
+  (call-with-semaphore
+    (connection-output-lock conn)
+    (thunk (log-irc-info "» ~a" msg)
+           (fprintf (connection-output conn) "~A\r\n" msg)
+           (flush-output (connection-output conn)))))
+
+(define (listen)
+  (let ([input (connection-input (current-connection))])
+    (let loop ()
+      (let* ([l (read-line input 'any)]
+             [msg (msg-parse l)])
+        (log-irc-info "« ~a" msg)
+        (thread (thunk (hook-process msg))))
+      (loop))))
diff --git a/irc/fancy.rkt b/irc/fancy.rkt
new file mode 100644
index 0000000..362ce74
--- /dev/null
+++ b/irc/fancy.rkt
@@ -0,0 +1,53 @@
+#lang racket/base
+(require racket/format)
+(provide clear fg bg col bold italic underline)
+
+(define colors
+  '((white  "00")
+    (black  "01")
+    (blue   "02")
+    (green  "03")
+    (red    "04")
+    (brown  "05")
+    (purple "06")
+    (orange "07")
+    (yellow "08")
+    (lime   "09")
+    (teal   "10")
+    (lcyan  "11")
+    (lblue  "12")
+    (pink   "13")
+    (grey   "14")
+    (lgrey  "15")
+    (transp "99")))
+
+(define (clear . args)
+  (string-append "\x0F" (apply string-append (map ~a args)) "\x0F"))
+
+(define (fg f . args)
+  (let ([col (cond [(symbol? f)
+                    (let ([l (cadr (assv f colors))])
+                      (if l l (raise (list "color " f " is invalid"))))]
+                   [else (~a f)])])
+    (string-append "\x03" col (apply string-append (map ~a args)) "\x03")))
+
+(define (bg b . args)
+  (let ([col (cond [(symbol? b)
+                    (let ([l (cadr (assv b colors))])
+                      (if l l (raise (list "color " b " is invalid"))))]
+                   [else (~a b)])])
+    (string-append "\x03," col (apply string-append (map ~a args)) "\x03")))
+
+(define (col f b . args)
+  (string-append "\x03"
+    (cadr (assv f colors)) "," (assv b colors)
+    (apply string-append (map ~a args)) "\x03"))
+
+(define (bold . args)
+  (string-append "\x02" (apply string-append (map ~a args)) "\x02"))
+
+(define (italic . args)
+  (string-append "\x1D" (apply string-append (map ~a args)) "\x1D"))
+
+(define (underline . args)
+  (string-append "\x1F" (apply string-append (map ~a args)) "\x1F"))