blob: fa5edceb25e5a9f4e11a415741d16bc469ec3674 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
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))))
|