blob: a24747ea8ac7f4ae995881f8e73c1600c47e12f6 (
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
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
#lang racket/base
(require (for-syntax racket/provide) racket/provide
racket/string racket/format racket/list
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 hook-abort
msg send listen
connection-storage set-connection-storage!
(matching-identifiers-out #rx"^log-irc-" (all-defined-out))
(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) (log-irc-error (exn->string x)))))
(struct connection
(input output hooks output-lock storage)
#: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) #f))
(define (hook-add conn fn)
(set-connection-hooks! conn (cons fn (connection-hooks conn))))
(define hook-abort (string->uninterned-symbol "abort"))
(define (hook-process msg)
(define conn (current-connection))
; TODO add synchronisation
(with-handlers ([exn:fail? (current-hook-fail-handler)])
(parameterize ([current-message msg])
(set-connection-hooks! conn
(filter-not (λ (h) (eq? (h) hook-abort))
(connection-hooks conn))))))
(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 (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)))
(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) (list (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)])
(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" 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)])
(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))))
|