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