1 files changed, 128 insertions, 0 deletions
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))))