/servers.rkt

  1#! /bin/sh
  2#| Hey Emacs, this is -*-scheme-*- code!
  3if [ "x$BOTDEBUG" != "xno" ]; then
  4  exec racket -l errortrace --require $0 --main -- ${1+"$@"}
  5else
  6  exec racket --require $0 --main -- ${1+"$@"}
  7fi
  8|#
  9
 10#lang racket
 11
 12(require "loop.rkt"
 13         (except-in "vars.rkt" log)
 14         "git-version.rkt"
 15         (except-in "quotes.rkt" main)
 16         (except-in "clearenv.rkt" main)
 17         (only-in "incubot.rkt" make-test-corpus)
 18         (only-in "iserver.rkt" make-incubot-server)
 19         scheme/port)
 20
 21(define (real-server)
 22  (let-values ([(ip op) (tcp-connect (*irc-server-hostname*)
 23                                     (*irc-server-port*))])
 24    (file-stream-buffer-mode op 'line)
 25    (values ip op)))
 26
 27(define (make-preloaded-server op)
 28  (lambda ()
 29    (values (let-values ([(ip op) (make-pipe)])
 30              (thread
 31               (lambda ()
 32                 (define (meh str)
 33                   (format ":n!n@n PRIVMSG #c :~a"
 34                           str))
 35                 (define (c str)
 36                   (format ":n!n@n PRIVMSG #c :~a: ~a"
 37                           (unbox *my-nick*)
 38                           str))
 39                 (define (p str)
 40                   (format ":n!n@n PRIVMSG ~a :~a"
 41                           (unbox *my-nick*)
 42                           str))
 43                 (for-each
 44                  (lambda (line)
 45                    (display line op)
 46                    (display "\r\n" op))
 47                  (cond
 48                   (#f
 49                    (list
 50                     (meh "Hey everyone!  What's happening?")
 51                     (c "uptime")
 52                     (c "settle")
 53                     (meh "frotz: plotz.")
 54                     (c "everyone")
 55                     (c "plotz")
 56                     (meh "\1ACTION fred eats salami\1")
 57                     (c "salami")))
 58                   (#f
 59                    ;; Typical stuff from ircd-seven
 60                    `(":bartol.freenode.net NOTICE * :*** No Ident response"
 61                      ":notice!NickServ@services. NOTICE rudybot :This nickname is registered. Please choose a different nickname, or identify via \u0002/msg NickServ identify <password>\u0002.")
 62                    )
 63                   (#f
 64                    `(
 65                      ":t8!n=foo@bar PRIVMSG #ch :,t8"
 66                      ":t8!n=foo@bar PRIVMSG #ch :,t8 fr"
 67                      ":t8!n=foo@bar PRIVMSG #ch :,t8 fr de"
 68                      ,(format ":t8!n=foo@bar PRIVMSG #ch :~a: t8 en it kits, cats, sacks, wives: how many were going to St Ives?" (unbox *my-nick*))
 69                      ":t8!n=foo@bar PRIVMSG #ch :,t8 en hu I will not buy this record, it is scratched"
 70                      ":t8!n=foo@bar PRIVMSG #ch : ,t8 en hu I will not buy this translation; it contains leading whitespace"))
 71                   (else
 72                    `(
 73                      ,(c (format "eval (error \"foo\\r\\nQUIT bar\")"))
 74                      ":freenode-connect!freenode@freenode/bot/connect PRIVMSG upstartbot :\u0001VERSION\u0001"
 75                      "foO!"
 76                      "PING :localhost."
 77                      ":sykopomp!n=user@host-70-45-40-165.onelinkpr.net PRIVMSG #emacs :\u0001ACTION is wondering if it's easy to save any logs from bitlbee to a different folder than all the irc logs.\u0001"
 78                      ":arcfide!n=arcfide@VPNBG165-7.umsl.edu PRIVMSG #scheme :\u0001ACTION sighs. \u0001"
 79
 80                      ":action!n=No@unaffiliated/clue PRIVMSG #ch :\u0001ACTION does an action!\u0001"
 81                      ":invite!n=No@unaffiliated/clue INVITE upstartbot :##mircscripts"
 82                      ":join!n=Aaron@b415.adsl.ecomtel.com.au JOIN :#scheme"
 83                      ":duncanm!n=duncanm@b415.adsl.ecomtel.com.au JOIN :#scheme"
 84                      ":kick!n=chandler@opendarwin/developer/chandler KICK #scheme lumon :http://www.penny-arcade.com/comic/2003/11/07/"
 85                      ":kick2!n=asc@pdpc/supporter/active/kensanata KICK #emacs jordanb :you too"
 86                      ":mode!ChanServ@services. MODE #emacs +o alephnull "
 87                      ":nick!n=Aaron@b415.adsl.ecomtel.com.au NICK :AshyIsMe"
 88                      ":nick2!n=Aaron@b415.adsl.ecomtel.com.au NICK :AshyIsMe"
 89                      ":notice!NickServ@services. NOTICE rudybot :This nickname is registered. Please choose a different nickname, or identify via \u0002/msg NickServ identify <password>\u0002."
 90                      ":notice2!i=christel@freenode/staff/exherbo.christel NOTICE $* :[Global Notice] Aaaaand we make contact! A small step for manki..oh wai-! Sorry about the delay there and thank you for your patience. Services are now back up!"
 91                      ":part!n=Akaleb@bl6-112-187.dsl.telepac.pt PART #emacs :\"Changed major mode\""
 92                      ":quit!n=adam@yax.org.uk PRIVMSG #ch :This is my last utterance before quitting."
 93                      ":quit!n=adam@yax.org.uk QUIT :Client Quit"
 94                      ":topic!n=javachat@cpe-74-71-143-65.twcny.res.rr.com TOPIC #emacs :-=[ www.WHAK.com ]=- Make Free/Fun Graphics Online At http://www.ImageGenerator.org =)"
 95
 96                      ,(c "version")
 97                      ,(c "SOURCE")
 98                      ,(c "quote")
 99                      ,(format ":t8!n=foo@bar PRIVMSG #ch :~a: t8 en it kits, cats, sacks, wives: how many were going to St Ives?" (unbox *my-nick*))
100                      ":t8!n=foo@bar PRIVMSG #ch :,t8 en hu I will not buy this record, it is scratched"
101                      ":t8!n=foo@bar PRIVMSG #ch : ,t8 en hu I will not buy this translation; it contains leading whitespace"
102
103                      ,(format ":t8!n=foo@bar PRIVMSG #ch :~a: t8 snord horde" (unbox *my-nick*))
104
105                      ,(format ":jordanb!n@n PRIVMSG #c :~a: quote" (unbox *my-nick*))
106                      ,(format ":jordanb!n@n PRIVMSG #c :Let's say something memorable")
107                      ,(format ":n!n@n PRIVMSG #emacs :,...")
108                      ,(format ":n!n@n PRIVMSG #not-emacs :,...")
109                      ,(format ":n!n@n PRIVMSG #c :~a:~a" (unbox *my-nick*) "lookboynospaces")
110                      ,(format ":n!n@n PRIVMSG #c :~a:" (unbox *my-nick*) )
111                      ,@(for/list ([action (in-list (list "action" "invite" "join" "kick" "kick2" "mode" "nick" "nick2" "notice" "notice2" "part" "quit" "topic"))])
112                          (c (format "seen ~a" action)))
113
114                      ":niven.freenode.net 001 rudybot :Welcome to the freenode IRC Network rudybot"
115                      ,(format
116                        ":NickServ!NickServ@services. NOTICE ~a :If this is your nickname, type /msg NickServ \0002IDENTIFY\0002 <password>"
117                        (unbox *my-nick*))
118
119                      ,@(apply
120                         append
121                         (for/list ([expr (in-list '((+ 2 1)
122                                                     (begin (display (+ 2 1)) (newline))
123                                                     (let loop ()
124                                                       (printf "Yaa!!")
125                                                       (loop))
126                                                     (require srfi/1)
127                                                     (make-list 100000)
128                                                     (apply values (make-list 100000))))])
129                           (list
130                            (c (format "eval ~s" expr))
131                            (p (format "eval ~s" expr)))))
132
133                      ,@(map c (list "quote" "uptime"))
134                      ,@(map p (list "This is a private utterance, and I certainly hope you don't divulge it!!"))
135                      ,(c "seen n")
136                      ;; This should work, if you set BOTMASTER in the
137                      ;; environment before running this test.
138                      ,(c "system ls /")
139
140                      ;; This should yield an empty string.
141                      ,(c "eval (getenv \"PATH\")")
142
143                      ;; This should simply not blow up.
144                      ,(p "eval (number->string #d10000000000000000000000000000000000000000000000000000000000 16)")
145                      ))))
146                 (close-output-port op)))
147              ip)
148            op)))
149
150(define (make-log-replaying-ip-port log-file-name (max-lines 'all))
151  (let-values ([(ip op) (make-pipe)])
152    (thread
153     (lambda ()
154       (call-with-input-file log-file-name
155         (lambda (ip)
156           (let/ec return
157             (for ([line (in-lines ip)]
158                   [lines-handled (in-naturals)])
159               (when (equal? lines-handled max-lines)
160                 (return))
161               (match line
162                 [(regexp #px"<= (\".*\")" (list _ datum))
163                  (display (read (open-input-string datum)) op)
164                  (display #\return op)
165                  (newline op)]
166                 [_ #f])))
167           (close-output-port op)))))
168    ip))
169
170(define (make-flaky-server log-file-name)
171  (lambda ()
172    (when (zero? (random 3))
173      (raise (make-exn:fail:network
174              "de network, she be broke"
175              (current-continuation-marks))))
176
177    (values (make-log-replaying-ip-port log-file-name 20)
178            (open-output-nowhere))))
179
180(define (make-log-replaying-server log-file-name)
181  (lambda ()
182    (values (make-log-replaying-ip-port log-file-name)
183            (relocate-output-port
184             (current-output-port)
185             #f #f 1 #f))))
186
187(define (make-random-server)
188
189  (define (random-bytes [length 200])
190    (let ([r (make-bytes length)])
191      (for ([i (in-range length)])
192        (let new-byte ()
193          (let ([b (random 256)])
194            (case b
195              [(10 13) (new-byte)]
196              [else    (bytes-set! r i b)]))))
197      r))
198
199  (let-values ([(ip op) (make-pipe)])
200    (thread
201     (lambda ()
202       (let loop ([lines-emitted 0])
203         (when (< lines-emitted 200)
204           (display #":ow!ow@ow PRIVMSG #ow :" op)
205           (display (random-bytes) op)
206           (display #"\r\n" op)
207           (loop (add1 lines-emitted))))
208       (close-output-port op)))
209
210    (values ip (open-output-nowhere))))
211
212(define (make-hanging-up-server)
213  (lambda ()
214    (let-values ([(ip op) (make-pipe)])
215      (thread
216       (lambda ()
217         (for ([line (in-list '("NOTICE AUTH :*** Looking up your hostname..."
218                                "NOTICE AUTH :*** Found your hostname, welcome back"
219                                "NOTICE AUTH :*** Checking ident"
220                                "NOTICE AUTH :*** No identd (auth) response"
221                                "ERROR :Closing Link: 127.0.0.1 (Connection Timed Out)"))])
222           (fprintf op "~a\r~%" line))
223
224         (sleep 1)
225         (close-output-port op)))
226
227      (values ip (open-output-nowhere)))))
228
229
230(define (replay-main . args)
231  (parameterize ([*bot-gives-up-after-this-many-silent-seconds* 1/4]
232                 [*log-ports* (list (current-error-port))])
233    (log "Main starting.")
234    (connect-and-run
235     (make-log-replaying-server "big-log")
236     #:retry-on-hangup? #f)))
237
238(define (preload-main . args)
239  (log "Main starting.")
240  (parameterize ([*bot-gives-up-after-this-many-silent-seconds* 1/4]
241                 [*log-ports* (list (current-error-port))]
242                 [*incubot-server* (make-incubot-server (make-test-corpus))]
243                 [*incubot-logger* log])
244    (connect-and-run
245     (make-preloaded-server (open-output-nowhere))
246     #:retry-on-hangup? #f)))
247
248(define (localhost-main . args)
249  (log "Main starting: ~a" (git-version))
250  (parameterize ([*irc-server-hostname* "localhost"])
251    (connect-and-run real-server)))
252
253(define (flaky-main . args)
254  (parameterize ([*bot-gives-up-after-this-many-silent-seconds* 1/4]
255                 [*log-ports* (list (current-error-port))])
256    (random-seed 0)
257    (connect-and-run
258     (make-flaky-server "big-log")
259     #:retry-on-hangup? #t)))
260
261(define (random-main . args)
262  (parameterize ([*bot-gives-up-after-this-many-silent-seconds* 1/4]
263                 [*log-ports* (list (current-error-port))])
264    (random-seed 0)
265    (connect-and-run
266     make-random-server
267     #:retry-on-hangup? #f)))
268
269(define (hanging-up-main . args)
270  (parameterize ([*log-ports* (list (current-error-port))])
271    (connect-and-run
272     (make-hanging-up-server))))
273
274(define (main . args)
275  (fprintf (current-error-port) "Say goodbye to your environment ...")
276  (clearenv)
277  (fprintf (current-error-port) " poof~%")
278;;  flaky-main
279;;;   hanging-up-main
280;;;   (localhost-main)
281     (preload-main)
282;;;   random-main
283;;;   replay-main
284  )
285(provide (all-defined-out))