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