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