diff options
Diffstat (limited to 'irc')
| -rw-r--r-- | irc/bot.rkt | 77 | ||||
| -rw-r--r-- | irc/core.rkt | 128 | ||||
| -rw-r--r-- | irc/fancy.rkt | 53 |
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")) |