blob: 7975786f84d4f501bf31f7e65c64b08675e8a76b (
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
|
#lang racket/base
(require "core.rkt"
(for-syntax racket/base racket/syntax)
racket/string racket/function
racket/stxparam
racket/sandbox)
(provide (all-defined-out))
(define (replace-many s rep)
(foldl (λ (rep acc) (apply string-replace acc rep)) s rep))
(define casemap-empty '())
(define casemap-uppercase-strict-rfc1459
'(("{" "[") ("}" "]") ("|" "\\")))
(define casemap-lowercase-strict-rfc1459
(map reverse casemap-uppercase-strict-rfc1459))
(define casemap-uppercase-relaxed-rfc1459
(cons '("^" "~") casemap-uppercase-strict-rfc1459))
(define casemap-lowercase-relaxed-rfc1459
(map reverse casemap-uppercase-relaxed-rfc1459))
(define (irc-downcase s [casemap casemap-lowercase-relaxed-rfc1459])
(replace-many (string-downcase s) casemap))
(define (irc-upcase s [casemap casemap-uppercase-relaxed-rfc1459])
(replace-many (string-upcase s) casemap))
(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 (unaltered-source) (message-prefix-nick (current-message)))
(define (source) (irc-downcase (unaltered-source)))
(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 "0"]
#:unused [unused "*"] #:realname [realname user]
#:pass [pass #f]
#:capabilities [caps '()])
(for-each (λ (cap) (send (msg 'CAP '("REQ") cap))) caps)
(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 (part chans [reason #f])
(send (msg 'PART (list chans) reason)))
(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 ...))))
(define-syntax-rule (on-once condition action ...)
(on condition action ... hook-abort))
; does this belong here?
; limit to 5s, 25MB to prevent reading 2^30 element vectors
(define read-sandbox
(parameterize ([sandbox-eval-limits '(5 25)])
(make-evaluator 'racket/base)))
(define (safe-read-string s)
(call-with-default-reading-parameterization
(thunk
(parameterize ([read-square-bracket-as-paren #f]
[read-curly-brace-as-paren #f]
[read-accept-compiled #f]
[read-accept-reader #f]
[read-accept-lang #f])
(read-sandbox `(read (open-input-string ,s)))))))
|