summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--irc/bot.rkt77
-rw-r--r--irc/core.rkt128
-rw-r--r--irc/fancy.rkt53
-rw-r--r--main.rkt14
-rw-r--r--modules/1-ping.rkt5
-rw-r--r--modules/3-bots.rkt5
-rw-r--r--modules/3-youtube.rkt26
-rw-r--r--modules/9-listen.rkt6
8 files changed, 314 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"))
diff --git a/main.rkt b/main.rkt
new file mode 100644
index 0000000..af82963
--- /dev/null
+++ b/main.rkt
@@ -0,0 +1,14 @@
+#lang racket/base
+(require racket/runtime-path)
+(define-runtime-path here ".")
+(define-runtime-path modules "modules")
+
+(current-library-collection-paths (cons here (current-library-collection-paths)))
+
+(define (require-path p)
+ (dynamic-require `(file ,(path->string p)) #f))
+
+(for ([f (directory-list modules #:build? #t)])
+ (if (file-exists? f)
+ (require-path f)
+ (require-path (build-path f "default.rkt"))))
diff --git a/modules/1-ping.rkt b/modules/1-ping.rkt
new file mode 100644
index 0000000..fc03c0e
--- /dev/null
+++ b/modules/1-ping.rkt
@@ -0,0 +1,5 @@
+#lang racket/base
+(require irc/core irc/bot)
+
+(on (command-is 'PING)
+ (send (msg 'PONG '() (suffix))))
diff --git a/modules/3-bots.rkt b/modules/3-bots.rkt
new file mode 100644
index 0000000..6ef9b77
--- /dev/null
+++ b/modules/3-bots.rkt
@@ -0,0 +1,5 @@
+#lang racket/base
+(require irc/bot)
+
+(on (suffix-is ".bots")
+ (reply "Reporting in! [Racket]"))
diff --git a/modules/3-youtube.rkt b/modules/3-youtube.rkt
new file mode 100644
index 0000000..835bee9
--- /dev/null
+++ b/modules/3-youtube.rkt
@@ -0,0 +1,26 @@
+#lang racket/base
+(require irc/bot racket/string net/url net/uri-codec json)
+(provide (all-defined-out))
+
+(define (youtube-query url)
+ (call/input-url
+ (string->url (format "https://noembed.com/embed?url=~a"
+ (uri-encode (url->string url))))
+ get-pure-port read-json))
+
+; catch youtube.com and youtu.be
+(define (extract-youtube-url s)
+ (define (is-yt-url u)
+ (and (url-host u)
+ (string-contains? (url-host u) "youtu")))
+
+ (let* ([urls (map string->url (string-split s))])
+ (findf is-yt-url urls)))
+
+(on (and (command-is 'PRIVMSG)
+ (context-is "#code"))
+ (let ([url (extract-youtube-url (suffix))])
+ (when url
+ (let* ([response (youtube-query url)]
+ [title (hash-ref response 'title)])
+ (reply (format "\"~a\"" title))))))
diff --git a/modules/9-listen.rkt b/modules/9-listen.rkt
new file mode 100644
index 0000000..4ff35e8
--- /dev/null
+++ b/modules/9-listen.rkt
@@ -0,0 +1,6 @@
+#lang racket/base
+(require irc/core)
+(listen)
+
+; okay, maybe this is overdoing the modularity bit,
+; but I don't know where else to put this