extra/irc/client/client.factor

   1 ! Copyright (C) 2008 Bruno Deferrari, Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: concurrency.mailboxes kernel io.sockets io.encodings.8-bit calendar
   4        accessors destructors namespaces io assocs arrays qualified fry
   5        continuations threads strings classes combinators splitting hashtables
   6        ascii irc.messages ;
   7 RENAME: join sequences => sjoin
   8 EXCLUDE: sequences => join ;
   9 IN: irc.client
  10
  11 ! ======================================
  12 ! Setup and running objects
  13 ! ======================================
  14
  15 : irc-port 6667 ; ! Default irc port
  16
  17 TUPLE: irc-profile server port nickname password ;
  18 C: <irc-profile> irc-profile
  19
  20 TUPLE: irc-client profile stream in-messages out-messages join-messages
  21        listeners is-running connect reconnect-time ;
  22 : <irc-client> ( profile -- irc-client )
  23     f <mailbox> <mailbox> <mailbox> H{ } clone f
  24     [ <inet> latin1 <client> ] 15 seconds irc-client boa ;
  25
  26 TUPLE: irc-listener in-messages out-messages ;
  27 TUPLE: irc-server-listener < irc-listener ;
  28 TUPLE: irc-channel-listener < irc-listener name password timeout participants ;
  29 TUPLE: irc-nick-listener < irc-listener name ;
  30 SYMBOL: +server-listener+
  31
  32 ! participant modes
  33 SYMBOL: +operator+
  34 SYMBOL: +voice+
  35 SYMBOL: +normal+
  36
  37 : participant-mode ( n -- mode )
  38     H{ { 64 +operator+ } { 43 +voice+ } { 0 +normal+ } } at ;
  39
  40 ! participant changed actions
  41 SYMBOL: +join+
  42 SYMBOL: +part+
  43 SYMBOL: +mode+
  44 SYMBOL: +nick+
  45
  46 ! listener objects
  47 : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
  48
  49 : <irc-server-listener> ( -- irc-server-listener )
  50      <mailbox> <mailbox> irc-server-listener boa ;
  51
  52 : <irc-channel-listener> ( name -- irc-channel-listener )
  53      [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone
  54      irc-channel-listener boa ;
  55
  56 : <irc-nick-listener> ( name -- irc-nick-listener )
  57      [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
  58
  59 ! ======================================
  60 ! Message objects
  61 ! ======================================
  62
  63 TUPLE: participant-changed nick action parameter ;
  64 C: <participant-changed> participant-changed
  65
  66 SINGLETON: irc-listener-end ! send to a listener to stop its execution
  67 SINGLETON: irc-end          ! sent when the client isn't running anymore
  68 SINGLETON: irc-disconnected ! sent when connection is lost
  69 SINGLETON: irc-connected    ! sent when connection is established
  70
  71 : terminate-irc ( irc-client -- )
  72     [ is-running>> ] keep and [
  73         [ [ irc-end ] dip in-messages>> mailbox-put ]
  74         [ [ f ] dip (>>is-running) ]
  75         [ stream>> dispose ]
  76         tri
  77     ] when* ;
  78
  79 <PRIVATE
  80
  81 SYMBOL: current-irc-client
  82
  83 ! ======================================
  84 ! Utils
  85 ! ======================================
  86
  87 : irc> ( -- irc-client ) current-irc-client get ;
  88 : irc-stream> ( -- stream ) irc> stream>> ;
  89 : irc-write ( s -- ) irc-stream> stream-write ;
  90 : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
  91 : irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
  92 : listener> ( name -- listener/f ) irc> listeners>> at ;
  93
  94 : maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
  95     [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline
  96
  97 GENERIC: to-listener ( message obj -- )
  98
  99 M: string to-listener ( message string -- )
 100     listener> [ +server-listener+ listener> ] unless*
 101     [ to-listener ] [ drop ] if* ;
 102
 103 M: irc-listener to-listener ( message irc-listener -- )
 104     in-messages>> mailbox-put ;
 105
 106 : unregister-listener ( name -- )
 107     irc> listeners>>
 108         [ at [ irc-listener-end ] dip to-listener ]
 109         [ delete-at ]
 110     2bi ;
 111
 112 : (remove-participant) ( nick listener -- )
 113     [ participants>> delete-at ]
 114     [ [ +part+ f <participant-changed> ] dip to-listener ] 2bi ;
 115
 116 : remove-participant ( nick channel -- )
 117     listener> [ (remove-participant) ] [ drop ] if* ;
 118
 119 : listeners-with-participant ( nick -- seq )
 120     irc> listeners>> values
 121     [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
 122     with filter ;
 123
 124 : to-listeners-with-participant ( message nickname -- )
 125     listeners-with-participant [ to-listener ] with each ;
 126
 127 : remove-participant-from-all ( nick -- )
 128     dup listeners-with-participant [ (remove-participant) ] with each ;
 129
 130 : notify-rename ( newnick oldnick listener -- )
 131     [ participant-changed new +nick+ >>action
 132       [ (>>nick) ] [ (>>parameter) ] [ ] tri ] dip to-listener ;
 133
 134 : rename-participant ( newnick oldnick listener -- )
 135     [ participants>> [ delete-at* drop ] [ [ swap ] dip set-at ] bi ]
 136     [ notify-rename ] 3bi ;
 137
 138 : rename-participant-in-all ( oldnick newnick -- )
 139     swap dup listeners-with-participant [ rename-participant ] with with each ;
 140
 141 : add-participant ( mode nick channel -- )
 142     listener> [
 143         [ participants>> set-at ]
 144         [ [ +join+ f <participant-changed> ] dip to-listener ] 2bi
 145     ] [ 2drop ] if* ;
 146
 147 DEFER: me?
 148
 149 : maybe-forward-join ( join -- )
 150     [ irc-message-sender me? ] keep and
 151     [ irc> join-messages>> mailbox-put ] when* ;
 152
 153 ! ======================================
 154 ! IRC client messages
 155 ! ======================================
 156
 157 : /NICK ( nick -- )
 158     "NICK " irc-write irc-print ;
 159
 160 : /LOGIN ( nick -- )
 161     dup /NICK
 162     "USER " irc-write irc-write
 163     " hostname servername :irc.factor" irc-print ;
 164
 165 : /CONNECT ( server port -- stream )
 166     irc> connect>> call drop ;
 167
 168 : /JOIN ( channel password -- )
 169     "JOIN " irc-write
 170     [ [ " :" ] dip 3append ] when* irc-print ;
 171
 172 : /PONG ( text -- )
 173     "PONG " irc-write irc-print ;
 174
 175 ! ======================================
 176 ! Server message handling
 177 ! ======================================
 178
 179 : me? ( string -- ? )
 180     irc> profile>> nickname>> = ;
 181
 182 GENERIC: forward-name ( irc-message -- name )
 183 M: join forward-name ( join -- name ) trailing>> ;
 184 M: part forward-name ( part -- name ) channel>> ;
 185 M: kick forward-name ( kick -- name ) channel>> ;
 186 M: mode forward-name ( mode -- name ) channel>> ;
 187 M: privmsg forward-name ( privmsg -- name )
 188     dup name>> me? [ irc-message-sender ] [ name>> ] if ;
 189
 190 UNION: single-forward join part kick mode privmsg ;
 191 UNION: multiple-forward nick quit ;
 192 UNION: broadcast-forward irc-end irc-disconnected irc-connected ;
 193 GENERIC: forward-message ( irc-message -- )
 194
 195 M: irc-message forward-message ( irc-message -- )
 196     +server-listener+ listener> [ to-listener ] [ drop ] if* ;
 197
 198 M: single-forward forward-message ( forward-single -- )
 199     dup forward-name to-listener ;
 200
 201 M: multiple-forward forward-message ( multiple-forward -- )
 202     dup irc-message-sender to-listeners-with-participant ;
 203
 204 M: join forward-message ( join -- )
 205     [ maybe-forward-join ] [ call-next-method ] bi ;
 206
 207 M: broadcast-forward forward-message ( irc-broadcasted-message -- )
 208     irc> listeners>> values [ to-listener ] with each ;
 209
 210 GENERIC: process-message ( irc-message -- )
 211
 212 M: object process-message ( object -- )
 213     drop ;
 214
 215 M: logged-in process-message ( logged-in -- )
 216     name>> irc> profile>> (>>nickname) ;
 217
 218 M: ping process-message ( ping -- )
 219     trailing>> /PONG ;
 220
 221 M: nick-in-use process-message ( nick-in-use -- )
 222     name>> "_" append /NICK ;
 223
 224 M: join process-message ( join -- )
 225     [ drop +normal+ ] [ irc-message-sender ] [ trailing>> ] tri add-participant ;
 226
 227 M: part process-message ( part -- )
 228     [ irc-message-sender ] [ channel>> ] bi remove-participant ;
 229
 230 M: kick process-message ( kick -- )
 231     [ [ who>> ] [ channel>> ] bi remove-participant ]
 232     [ dup who>> me? [ unregister-listener ] [ drop ] if ]
 233     bi ;
 234
 235 M: quit process-message ( quit -- )
 236     irc-message-sender remove-participant-from-all ;
 237
 238 M: nick process-message ( nick -- )
 239     [ irc-message-sender ] [ trailing>> ] bi rename-participant-in-all ;
 240
 241 : >nick/mode ( string -- nick mode )
 242     dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
 243
 244 : names-reply>participants ( names-reply -- participants )
 245     trailing>> [ blank? ] trim " " split
 246     [ >nick/mode 2array ] map >hashtable ;
 247
 248 M: names-reply process-message ( names-reply -- )
 249     [ names-reply>participants ] [ channel>> listener> ] bi [
 250         [ (>>participants) ]
 251         [ [ f f f <participant-changed> ] dip name>> to-listener ] bi
 252     ] [ drop ] if* ;
 253
 254 : handle-incoming-irc ( irc-message -- )
 255     [ forward-message ] [ process-message ] bi ;
 256
 257 ! ======================================
 258 ! Client message handling
 259 ! ======================================
 260
 261 : handle-outgoing-irc ( irc-message -- )
 262     irc-message>client-line irc-print ;
 263
 264 ! ======================================
 265 ! Reader/Writer
 266 ! ======================================
 267
 268 : handle-reader-message ( irc-message -- )
 269     irc> in-messages>> mailbox-put ;
 270
 271 DEFER: (connect-irc)
 272
 273 : (handle-disconnect) ( -- )
 274     irc>
 275         [ [ irc-disconnected ] dip in-messages>> mailbox-put ]
 276         [ dup reconnect-time>> sleep (connect-irc) ]
 277         [ profile>> nickname>> /LOGIN ]
 278     tri ;
 279
 280 ! FIXME: do something with the exception, store somewhere to help debugging
 281 : handle-disconnect ( error -- )
 282     drop irc> is-running>> [ (handle-disconnect) ] when ;
 283
 284 : (reader-loop) ( -- )
 285     irc> stream>> [
 286         |dispose stream-readln [
 287             parse-irc-line handle-reader-message
 288         ] [
 289             irc> terminate-irc
 290         ] if*
 291     ] with-destructors ;
 292
 293 : reader-loop ( -- ? )
 294     [ (reader-loop) ] [ handle-disconnect ] recover t ;
 295
 296 : writer-loop ( -- ? )
 297     irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ;
 298
 299 ! ======================================
 300 ! Processing loops
 301 ! ======================================
 302
 303 : in-multiplexer-loop ( -- ? )
 304     irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ;
 305
 306 : strings>privmsg ( name string -- privmsg )
 307     privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
 308
 309 : maybe-annotate-with-name ( name obj -- obj )
 310     { { [ dup string? ] [ strings>privmsg ] }
 311       { [ dup privmsg instance? ] [ swap >>name ] }
 312       [ nip ]
 313     } cond ;
 314
 315 : listener-loop ( name -- ? )
 316     dup listener> [
 317         out-messages>> [ maybe-annotate-with-name
 318                          irc> out-messages>> mailbox-put ] with
 319         maybe-mailbox-get t
 320     ] [ drop f ] if* ;
 321
 322 : spawn-irc-loop ( quot: ( -- ? ) name -- )
 323     [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
 324     spawn-server drop ;
 325
 326 : spawn-irc ( -- )
 327     [ reader-loop ] "irc-reader-loop" spawn-irc-loop
 328     [ writer-loop ] "irc-writer-loop" spawn-irc-loop
 329     [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
 330
 331 ! ======================================
 332 ! Listener join request handling
 333 ! ======================================
 334
 335 : set+run-listener ( name irc-listener -- )
 336     over irc> listeners>> set-at
 337     '[ , listener-loop ] "listener" spawn-irc-loop ;
 338
 339 GENERIC: (add-listener) ( irc-listener -- )
 340
 341 M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
 342     [ [ name>> ] [ password>> ] bi /JOIN ]
 343     [ [ [ drop irc> join-messages>> ]
 344         [ timeout>> ]
 345         [ name>> '[ trailing>> , = ] ]
 346         tri mailbox-get-timeout? trailing>> ] keep set+run-listener
 347     ] bi ;
 348
 349 M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
 350     [ name>> ] keep set+run-listener ;
 351
 352 M: irc-server-listener (add-listener) ( irc-server-listener -- )
 353     [ +server-listener+ ] dip set+run-listener ;
 354
 355 GENERIC: (remove-listener) ( irc-listener -- )
 356
 357 M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
 358     name>> unregister-listener ;
 359
 360 M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
 361     [ [ name>> ] [ out-messages>> ] bi
 362       [ [ part new ] dip >>channel ] dip mailbox-put ] keep
 363     name>> unregister-listener ;
 364
 365 M: irc-server-listener (remove-listener) ( irc-server-listener -- )
 366    drop +server-listener+ unregister-listener ;
 367
 368 : (connect-irc) ( irc-client -- )
 369     [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
 370         swap >>stream
 371         t >>is-running
 372     in-messages>> [ irc-connected ] dip mailbox-put ;
 373
 374 : with-irc-client ( irc-client quot: ( -- ) -- )
 375     [ \ current-irc-client ] dip with-variable ; inline
 376
 377 PRIVATE>
 378
 379 : connect-irc ( irc-client -- )
 380     [ irc>
 381       [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
 382       spawn-irc ] with-irc-client ;
 383
 384 : add-listener ( irc-listener irc-client -- )
 385     swap '[ , (add-listener) ] with-irc-client ;
 386
 387 : remove-listener ( irc-listener irc-client -- )
 388     swap '[ , (remove-listener) ] with-irc-client ;
 389
 390 : write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
 391 : read-message ( irc-listener -- message ) in-messages>> mailbox-get ;