Warn on lossy message parsing-formatting roundtrip

1 files changed, 15 insertions, 8 deletions

diff --git a/irc/core.rkt b/irc/core.rkt
index bbe6905..a24747e 100644
--- a/irc/core.rkt
+++ b/irc/core.rkt
@@ -55,10 +55,11 @@
         [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 (pair? tags)
+      (fprintf out "@~A "
+        (string-join
+          (map (λ (t) (string-append (car t) "=" (cdr t))) tags)
+          ";")))
 
     (when prefix (fprintf out ":~A " (clean prefix)))
     (fprintf out "~A" (clean (symbol->string cmd)))
@@ -119,17 +120,23 @@
   (message tags prefix cmd args suffix))
 
 (define (send msg #:conn [conn (current-connection)])
+  (define formatted (~a msg))
+  (define capped (substring formatted 0 (min 510 (string-length formatted))))
   (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)))))
+    (thunk (log-irc-info "» ~a" capped)
+           (define out (connection-output conn))
+           (display capped out)
+           (display "\r\n" out)
+           (flush-output out))))
 
 (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)
+        (when (not (string=? (~a msg) l))
+          (log-irc-warning "Message roundtrip lossy:\nActual: ~a\nParsed: ~a" l msg))
+        (log-irc-info "« ~a" l)
         (thread (thunk (hook-process msg))))
       (loop))))