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 irc.messages.private ;
   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
  45 ! listener objects
  46 : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
  47
  48 : <irc-server-listener> ( -- irc-server-listener )
  49      <mailbox> <mailbox> irc-server-listener boa ;
  50
  51 : <irc-channel-listener> ( name -- irc-channel-listener )
  52      [ <mailbox> <mailbox> ] dip f 60 seconds H{ } clone
  53      irc-channel-listener boa ;
  54
  55 : <irc-nick-listener> ( name -- irc-nick-listener )
  56      [ <mailbox> <mailbox> ] dip irc-nick-listener boa ;
  57
  58 ! ======================================
  59 ! Message objects
  60 ! ======================================
  61
  62 TUPLE: participant-changed nick action ;
  63 C: <participant-changed> participant-changed
  64
  65 SINGLETON: irc-listener-end ! send to a listener to stop its execution
  66 SINGLETON: irc-end          ! sent when the client isn't running anymore
  67 SINGLETON: irc-disconnected ! sent when connection is lost
  68 SINGLETON: irc-connected    ! sent when connection is established
  69 UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
  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 : listener> ( name -- listener/f ) irc> listeners>> at ;
  92
  93 : maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
  94     [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline
  95
  96 GENERIC: to-listener ( message obj -- )
  97
  98 M: string to-listener ( message string -- )
  99     listener> [ +server-listener+ listener> ] unless*
 100     [ to-listener ] [ drop ] if* ;
 101
 102 : unregister-listener ( name -- )
 103     irc> listeners>>
 104         [ at [ irc-listener-end ] dip to-listener ]
 105         [ delete-at ]
 106     2bi ;
 107
 108 M: irc-listener to-listener ( message irc-listener -- )
 109     in-messages>> mailbox-put ;
 110
 111 : remove-participant ( nick channel -- )
 112     listener> [ participants>> delete-at ] [ drop ] if* ;
 113
 114 : listeners-with-participant ( nick -- seq )
 115     irc> listeners>> values
 116     [ dup irc-channel-listener? [ participants>> key? ] [ 2drop f ] if ]
 117     with filter ;
 118
 119 : remove-participant-from-all ( nick -- )
 120     dup listeners-with-participant [ participants>> delete-at ] with each ;
 121
 122 : add-participant ( mode nick channel -- )
 123     listener> [ participants>> set-at ] [ 2drop ] if* ;
 124
 125 DEFER: me?
 126
 127 : maybe-forward-join ( join -- )
 128     [ prefix>> parse-name me? ] keep and
 129     [ irc> join-messages>> mailbox-put ] when* ;
 130
 131 ! ======================================
 132 ! IRC client messages
 133 ! ======================================
 134
 135 : /NICK ( nick -- )
 136     "NICK " irc-write irc-print ;
 137
 138 : /LOGIN ( nick -- )
 139     dup /NICK
 140     "USER " irc-write irc-write
 141     " hostname servername :irc.factor" irc-print ;
 142
 143 : /CONNECT ( server port -- stream )
 144     irc> connect>> call drop ;
 145
 146 : /JOIN ( channel password -- )
 147     "JOIN " irc-write
 148     [ [ " :" ] dip 3append ] when* irc-print ;
 149
 150 : /PART ( channel text -- )
 151     [ "PART " irc-write irc-write ] dip
 152     " :" irc-write irc-print ;
 153
 154 : /KICK ( channel who -- )
 155     [ "KICK " irc-write irc-write ] dip
 156     " " irc-write irc-print ;
 157
 158 : /PRIVMSG ( nick line -- )
 159     [ "PRIVMSG " irc-write irc-write ] dip
 160     " :" irc-write irc-print ;
 161
 162 : /ACTION ( nick line -- )
 163     [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ;
 164
 165 : /QUIT ( text -- )
 166     "QUIT :" irc-write irc-print ;
 167
 168 : /PONG ( text -- )
 169     "PONG " irc-write irc-print ;
 170
 171 ! ======================================
 172 ! Server message handling
 173 ! ======================================
 174
 175 : me? ( string -- ? )
 176     irc> profile>> nickname>> = ;
 177
 178 : irc-message-origin ( irc-message -- name )
 179     dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
 180
 181 : broadcast-message-to-listeners ( message -- )
 182     irc> listeners>> values [ to-listener ] with each ;
 183
 184 GENERIC: handle-participant-change ( irc-message -- )
 185
 186 M: join handle-participant-change ( join -- )
 187     [ prefix>> parse-name +join+ <participant-changed> ]
 188     [ trailing>> ] bi to-listener ;
 189
 190 M: part handle-participant-change ( part -- )
 191     [ prefix>> parse-name +part+ <participant-changed> ]
 192     [ channel>> ] bi to-listener ;
 193
 194 M: kick handle-participant-change ( kick -- )
 195     [ who>> +part+ <participant-changed> ]
 196     [ channel>> ] bi to-listener ;
 197
 198 M: quit handle-participant-change ( quit -- )
 199     prefix>> parse-name
 200     [ +part+ <participant-changed> ] [ listeners-with-participant ] bi
 201     [ to-listener ] with each ;
 202
 203 GENERIC: handle-incoming-irc ( irc-message -- )
 204
 205 M: irc-message handle-incoming-irc ( irc-message -- )
 206     +server-listener+ listener> [ to-listener ] [ drop ] if* ;
 207
 208 M: logged-in handle-incoming-irc ( logged-in -- )
 209     name>> irc> profile>> (>>nickname) ;
 210
 211 M: ping handle-incoming-irc ( ping -- )
 212     trailing>> /PONG ;
 213
 214 M: nick-in-use handle-incoming-irc ( nick-in-use -- )
 215     name>> "_" append /NICK ;
 216
 217 M: privmsg handle-incoming-irc ( privmsg -- )
 218     dup irc-message-origin to-listener ;
 219
 220 M: join handle-incoming-irc ( join -- )
 221     { [ maybe-forward-join ]
 222       [ dup trailing>> to-listener ]
 223       [ [ drop +normal+ ] [ prefix>> parse-name ] [ trailing>> ] tri add-participant ]
 224       [ handle-participant-change ]
 225     } cleave ;
 226
 227 M: part handle-incoming-irc ( part -- )
 228     [ dup channel>> to-listener ]
 229     [ [ prefix>> parse-name ] [ channel>> ] bi remove-participant ]
 230     [ handle-participant-change ]
 231     tri ;
 232
 233 M: kick handle-incoming-irc ( kick -- )
 234     { [ dup channel>> to-listener ]
 235       [ [ who>> ] [ channel>> ] bi remove-participant ]
 236       [ handle-participant-change ]
 237       [ dup who>> me? [ unregister-listener ] [ drop ] if ]
 238     } cleave ;
 239
 240 M: quit handle-incoming-irc ( quit -- )
 241     [ dup prefix>> parse-name listeners-with-participant
 242       [ to-listener ] with each ]
 243     [ prefix>> parse-name remove-participant-from-all ]
 244     [ handle-participant-change ]
 245     tri ;
 246
 247 : >nick/mode ( string -- nick mode )
 248     dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
 249
 250 : names-reply>participants ( names-reply -- participants )
 251     trailing>> [ blank? ] trim " " split
 252     [ >nick/mode 2array ] map >hashtable ;
 253
 254 M: names-reply handle-incoming-irc ( names-reply -- )
 255     [ names-reply>participants ] [ channel>> listener> ] bi [
 256         [ (>>participants) ]
 257         [ [ f f <participant-changed> ] dip name>> to-listener ] bi
 258     ] [ drop ] if* ;
 259
 260 M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
 261     broadcast-message-to-listeners ;
 262
 263 ! ======================================
 264 ! Client message handling
 265 ! ======================================
 266
 267 GENERIC: handle-outgoing-irc ( obj -- )
 268
 269 M: irc-message handle-outgoing-irc ( irc-message -- )
 270     irc-message>client-line irc-print ;
 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         [ profile>> nickname>> /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) ] when ;
 291
 292 : (reader-loop) ( -- )
 293     irc> stream>> [
 294         |dispose stream-readln [
 295             parse-irc-line handle-reader-message
 296         ] [
 297             irc> terminate-irc
 298         ] if*
 299     ] with-destructors ;
 300
 301 : reader-loop ( -- ? )
 302     [ (reader-loop) ] [ handle-disconnect ] recover t ;
 303
 304 : writer-loop ( -- ? )
 305     irc> out-messages>> [ handle-outgoing-irc ] maybe-mailbox-get t ;
 306
 307 ! ======================================
 308 ! Processing loops
 309 ! ======================================
 310
 311 : in-multiplexer-loop ( -- ? )
 312     irc> in-messages>> [ handle-incoming-irc ] maybe-mailbox-get t ;
 313
 314 : strings>privmsg ( name string -- privmsg )
 315     privmsg new [ (>>trailing) ] keep [ (>>name) ] keep ;
 316
 317 : maybe-annotate-with-name ( name obj -- obj )
 318     { { [ dup string? ] [ strings>privmsg ] }
 319       { [ dup privmsg instance? ] [ swap >>name ] }
 320       [ nip ]
 321     } cond ;
 322
 323 : listener-loop ( name -- ? )
 324     dup listener> [
 325         out-messages>> [ maybe-annotate-with-name
 326                          irc> out-messages>> mailbox-put ] with
 327         maybe-mailbox-get t
 328     ] [ drop f ] if* ;
 329
 330 : spawn-irc-loop ( quot: ( -- ? ) name -- )
 331     [ '[ irc> is-running>> [ @ ] [ f ] if ] ] dip
 332     spawn-server drop ;
 333
 334 : spawn-irc ( -- )
 335     [ reader-loop ] "irc-reader-loop" spawn-irc-loop
 336     [ writer-loop ] "irc-writer-loop" spawn-irc-loop
 337     [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
 338
 339 ! ======================================
 340 ! Listener join request handling
 341 ! ======================================
 342
 343 : set+run-listener ( name irc-listener -- )
 344     over irc> listeners>> set-at
 345     '[ , listener-loop ] "listener" spawn-irc-loop ;
 346
 347 GENERIC: (add-listener) ( irc-listener -- )
 348
 349 M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
 350     [ [ name>> ] [ password>> ] bi /JOIN ]
 351     [ [ [ drop irc> join-messages>> ]
 352         [ timeout>> ]
 353         [ name>> '[ trailing>> , = ] ]
 354         tri mailbox-get-timeout? trailing>> ] keep set+run-listener
 355     ] bi ;
 356
 357 M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
 358     [ name>> ] keep set+run-listener ;
 359
 360 M: irc-server-listener (add-listener) ( irc-server-listener -- )
 361     [ +server-listener+ ] dip set+run-listener ;
 362
 363 GENERIC: (remove-listener) ( irc-listener -- )
 364
 365 M: irc-nick-listener (remove-listener) ( irc-nick-listener -- )
 366     name>> unregister-listener ;
 367
 368 M: irc-channel-listener (remove-listener) ( irc-channel-listener -- )
 369     [ [ name>> ] [ out-messages>> ] bi
 370       [ [ part new ] dip >>channel ] dip mailbox-put ] keep
 371     name>> unregister-listener ;
 372
 373 M: irc-server-listener (remove-listener) ( irc-server-listener -- )
 374    drop +server-listener+ unregister-listener ;
 375
 376 : (connect-irc) ( irc-client -- )
 377     [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] keep
 378         swap >>stream
 379         t >>is-running
 380     in-messages>> [ irc-connected ] dip mailbox-put ;
 381
 382 : with-irc-client ( irc-client quot: ( -- ) -- )
 383     [ current-irc-client ] dip with-variable ; inline
 384
 385 PRIVATE>
 386
 387 : connect-irc ( irc-client -- )
 388     [ irc>
 389       [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
 390       spawn-irc ] with-irc-client ;
 391
 392 : add-listener ( irc-listener irc-client -- )
 393     swap '[ , (add-listener) ] with-irc-client ;
 394
 395 : remove-listener ( irc-listener irc-client -- )
 396     swap '[ , (remove-listener) ] with-irc-client ;
 397
 398 : write-message ( message irc-listener -- ) out-messages>> mailbox-put ;
 399 : read-message ( irc-listener -- message ) in-messages>> mailbox-get ;