extra/irc/client/client.factor

   1 ! Copyright (C) 2007 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays combinators concurrency.mailboxes io
   4        io.encodings.8-bit io.sockets kernel namespaces sequences
   5        sequences.lib splitting threads calendar classes.tuple
   6        classes ascii assocs accessors destructors continuations ;
   7 IN: irc.client
   8
   9 ! ======================================
  10 ! Setup and running objects
  11 ! ======================================
  12
  13 SYMBOL: current-irc-client
  14
  15 : irc-port 6667 ; ! Default irc port
  16
  17 ! "setup" objects
  18 TUPLE: irc-profile server port nickname password ;
  19 C: <irc-profile> irc-profile
  20
  21 TUPLE: irc-channel-profile name password ;
  22 : <irc-channel-profile> ( -- irc-channel-profile ) irc-channel-profile new ;
  23
  24 ! "live" objects
  25 TUPLE: nick name channels log ;
  26 C: <nick> nick
  27
  28 TUPLE: irc-client profile nick stream in-messages out-messages join-messages
  29        listeners is-running connect reconnect-time ;
  30 : <irc-client> ( profile -- irc-client )
  31     f V{ } clone V{ } clone <nick>
  32     f <mailbox> <mailbox> <mailbox> H{ } clone f
  33     [ <inet> latin1 <client> ] 15 seconds irc-client boa ;
  34
  35 TUPLE: irc-listener in-messages out-messages ;
  36 TUPLE: irc-server-listener < irc-listener ;
  37 TUPLE: irc-channel-listener < irc-listener name password timeout ;
  38 TUPLE: irc-nick-listener < irc-listener name ;
  39 UNION: irc-named-listener irc-nick-listener irc-channel-listener ;
  40
  41 : <irc-listener> ( -- irc-listener ) <mailbox> <mailbox> irc-listener boa ;
  42
  43 : <irc-server-listener> ( -- irc-server-listener )
  44      <mailbox> <mailbox> irc-server-listener boa ;
  45
  46 : <irc-channel-listener> ( name -- irc-channel-listener )
  47      <mailbox> <mailbox> rot f 60 seconds irc-channel-listener boa ;
  48
  49 : <irc-nick-listener> ( name -- irc-nick-listener )
  50      <mailbox> <mailbox> rot irc-nick-listener boa ;
  51
  52 ! ======================================
  53 ! Message objects
  54 ! ======================================
  55
  56 SINGLETON: irc-end          ! sent when the client isn't running anymore
  57 SINGLETON: irc-disconnected ! sent when connection is lost
  58 SINGLETON: irc-connected    ! sent when connection is instantiated
  59 UNION: irc-broadcasted-message irc-end irc-disconnected irc-connected ;
  60
  61 TUPLE: irc-message line prefix command parameters trailing timestamp ;
  62 TUPLE: logged-in < irc-message name ;
  63 TUPLE: ping < irc-message ;
  64 TUPLE: join < irc-message ;
  65 TUPLE: part < irc-message name channel ;
  66 TUPLE: quit < irc-message ;
  67 TUPLE: privmsg < irc-message name ;
  68 TUPLE: kick < irc-message channel who ;
  69 TUPLE: roomlist < irc-message channel names ;
  70 TUPLE: nick-in-use < irc-message asterisk name ;
  71 TUPLE: notice < irc-message type ;
  72 TUPLE: mode < irc-message name channel mode ;
  73 TUPLE: unhandled < irc-message ;
  74
  75 : terminate-irc ( irc-client -- )
  76     [ stream>> dispose ]
  77     [ in-messages>> irc-end swap mailbox-put ]
  78     [ f >>is-running drop ]
  79     tri ;
  80
  81 <PRIVATE
  82
  83 ! ======================================
  84 ! Shortcuts
  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
  92 ! ======================================
  93 ! IRC client messages
  94 ! ======================================
  95
  96 : /NICK ( nick -- )
  97     "NICK " irc-write irc-print ;
  98
  99 : /LOGIN ( nick -- )
 100     dup /NICK
 101     "USER " irc-write irc-write
 102     " hostname servername :irc.factor" irc-print ;
 103
 104 : /CONNECT ( server port -- stream )
 105     irc> connect>> call drop ;
 106
 107 : /JOIN ( channel password -- )
 108     "JOIN " irc-write
 109     [ " :" swap 3append ] when* irc-print ;
 110
 111 : /PART ( channel text -- )
 112     [ "PART " irc-write irc-write ] dip
 113     " :" irc-write irc-print ;
 114
 115 : /KICK ( channel who -- )
 116     [ "KICK " irc-write irc-write ] dip
 117     " " irc-write irc-print ;
 118
 119 : /PRIVMSG ( nick line -- )
 120     [ "PRIVMSG " irc-write irc-write ] dip
 121     " :" irc-write irc-print ;
 122
 123 : /ACTION ( nick line -- )
 124     [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ;
 125
 126 : /QUIT ( text -- )
 127     "QUIT :" irc-write irc-print ;
 128
 129 : /PONG ( text -- )
 130     "PONG " irc-write irc-print ;
 131
 132 ! ======================================
 133 ! Message parsing
 134 ! ======================================
 135
 136 : split-at-first ( seq separators -- before after )
 137     dupd [ member? ] curry find
 138         [ cut 1 tail ]
 139         [ swap ]
 140     if ;
 141
 142 : remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
 143
 144 : parse-name ( string -- string )
 145     remove-heading-: "!" split-at-first drop ;
 146
 147 : split-prefix ( string -- string/f string )
 148     dup ":" head?
 149         [ remove-heading-: " " split1 ]
 150         [ f swap ]
 151     if ;
 152
 153 : split-trailing ( string -- string string/f )
 154     ":" split1 ;
 155
 156 : string>irc-message ( string -- object )
 157     dup split-prefix split-trailing
 158     [ [ blank? ] trim " " split unclip swap ] dip
 159     now irc-message boa ;
 160
 161 : parse-irc-line ( string -- message )
 162     string>irc-message
 163     dup command>> {
 164         { "PING" [ \ ping ] }
 165         { "NOTICE" [ \ notice ] }
 166         { "001" [ \ logged-in ] }
 167         { "433" [ \ nick-in-use ] }
 168         { "JOIN" [ \ join ] }
 169         { "PART" [ \ part ] }
 170         { "PRIVMSG" [ \ privmsg ] }
 171         { "QUIT" [ \ quit ] }
 172         { "MODE" [ \ mode ] }
 173         { "KICK" [ \ kick ] }
 174         [ drop \ unhandled ]
 175     } case
 176     [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ;
 177
 178 ! ======================================
 179 ! Server message handling
 180 ! ======================================
 181
 182 : me? ( string -- ? )
 183     irc> nick>> name>> = ;
 184
 185 : irc-message-origin ( irc-message -- name )
 186     dup name>> me? [ prefix>> parse-name ] [ name>> ] if ;
 187
 188 : broadcast-message-to-listeners ( message -- )
 189     irc> listeners>> values [ in-messages>> mailbox-put ] with each ;
 190
 191 GENERIC: handle-incoming-irc ( irc-message -- )
 192
 193 M: irc-message handle-incoming-irc ( irc-message -- )
 194     drop ;
 195
 196 M: logged-in handle-incoming-irc ( logged-in -- )
 197     name>> irc> nick>> (>>name) ;
 198
 199 M: ping handle-incoming-irc ( ping -- )
 200     trailing>> /PONG ;
 201
 202 M: nick-in-use handle-incoming-irc ( nick-in-use -- )
 203     name>> "_" append /NICK ;
 204
 205 M: privmsg handle-incoming-irc ( privmsg -- )
 206     dup irc-message-origin irc> listeners>> at
 207     [ in-messages>> mailbox-put ] [ drop ] if* ;
 208
 209 M: join handle-incoming-irc ( join -- )
 210     irc> join-messages>> mailbox-put ;
 211
 212 M: irc-broadcasted-message handle-incoming-irc ( irc-broadcasted-message -- )
 213     broadcast-message-to-listeners ;
 214
 215 ! ======================================
 216 ! Client message handling
 217 ! ======================================
 218
 219 GENERIC: handle-outgoing-irc ( obj -- )
 220
 221 M: privmsg handle-outgoing-irc ( privmsg -- )
 222    [ name>> ] [ trailing>> ] bi /PRIVMSG ;
 223
 224 ! ======================================
 225 ! Reader/Writer
 226 ! ======================================
 227
 228 : irc-mailbox-get ( mailbox quot -- )
 229     swap 5 seconds  [ mailbox-get-timeout swap call ] 3curry [ drop ] recover ;
 230
 231 : stream-readln-or-close ( stream -- str/f )
 232     dup stream-readln [ nip ] [ dispose f ] if* ;
 233
 234 : handle-reader-message ( irc-message -- )
 235     irc> in-messages>> mailbox-put ;
 236
 237 DEFER: (connect-irc)
 238 : handle-disconnect ( error -- )
 239     drop irc>
 240         [ in-messages>> irc-disconnected swap mailbox-put ]
 241         [ reconnect-time>> sleep (connect-irc) ]
 242         [ profile>> nickname>> /LOGIN ]
 243     tri ;
 244
 245 : (reader-loop) ( -- )
 246     irc> stream>> [
 247         |dispose stream-readln [
 248             parse-irc-line handle-reader-message
 249         ] [
 250             irc> terminate-irc
 251         ] if*
 252     ] with-destructors ;
 253
 254 : reader-loop ( -- )
 255     [ (reader-loop) ] [ handle-disconnect ] recover ;
 256
 257 : writer-loop ( -- )
 258     irc> out-messages>> [ handle-outgoing-irc ] irc-mailbox-get ;
 259
 260 ! ======================================
 261 ! Processing loops
 262 ! ======================================
 263
 264 : in-multiplexer-loop ( -- )
 265     irc> in-messages>> [ handle-incoming-irc ] irc-mailbox-get ;
 266
 267 : maybe-annotate-with-name ( name obj -- obj )
 268     dup privmsg instance? [ swap >>name ] [ nip ] if ;
 269
 270 : listener-loop ( name listener -- )
 271     out-messages>> mailbox-get maybe-annotate-with-name
 272     irc> out-messages>> mailbox-put ;
 273
 274 : spawn-irc-loop ( quot name -- )
 275     [ [ irc> is-running>> ] compose ] dip
 276     spawn-server drop ;
 277
 278 : spawn-irc ( -- )
 279     [ reader-loop ] "irc-reader-loop" spawn-irc-loop
 280     [ writer-loop ] "irc-writer-loop" spawn-irc-loop
 281     [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-irc-loop ;
 282
 283 ! ======================================
 284 ! Listener join request handling
 285 ! ======================================
 286
 287 : set+run-listener ( name irc-listener -- )
 288     [ [ listener-loop ] 2curry "listener" spawn-irc-loop ]
 289     [ swap irc> listeners>> set-at ]
 290     2bi ;
 291
 292 GENERIC: (add-listener) ( irc-listener -- )
 293 M: irc-channel-listener (add-listener) ( irc-channel-listener -- )
 294     [ [ name>> ] [ password>> ] bi /JOIN ]
 295     [ [ [ drop irc> join-messages>> ]
 296         [ timeout>> ]
 297         [ name>> [ swap trailing>> = ] curry ]
 298         tri mailbox-get-timeout? trailing>> ] keep set+run-listener
 299     ] bi ;
 300
 301 M: irc-nick-listener (add-listener) ( irc-nick-listener -- )
 302    [ name>> ] keep set+run-listener ;
 303
 304 : (connect-irc) ( irc-client -- )
 305     [ profile>> [ server>> ] keep port>> /CONNECT ] keep
 306         swap >>stream
 307         t >>is-running
 308     in-messages>> irc-connected swap mailbox-put ;
 309
 310 PRIVATE>
 311
 312 : connect-irc ( irc-client -- )
 313     dup current-irc-client [
 314         [ (connect-irc) ] [ profile>> nickname>> /LOGIN ] bi
 315         spawn-irc
 316     ] with-variable ;
 317
 318 GENERIC: add-listener ( irc-client irc-listener -- )
 319 M: irc-listener add-listener ( irc-client irc-listener -- )
 320     current-irc-client swap [ (add-listener) ] curry with-variable ;