extra/irc/client/internals/internals.factor

   1 ! Copyright (C) 2009 Bruno Deferrari
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs arrays concurrency.mailboxes continuations destructors
   4 hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
   5 strings words.symbol irc.messages.base irc.client.participants fry threads
   6 combinators irc.messages.parser ;
   7 EXCLUDE: sequences => join ;
   8 IN: irc.client.internals
   9
  10 : /NICK ( nick -- ) "NICK " prepend irc-print ;
  11 : /PONG ( text -- ) "PONG " prepend irc-print ;
  12
  13 : /LOGIN ( nick -- )
  14     dup /NICK
  15     "USER " prepend " hostname servername :irc.factor" append irc-print ;
  16
  17 : /CONNECT ( server port -- stream )
  18     irc> connect>> call( host port -- stream local ) drop ;
  19
  20 : /JOIN ( channel password -- )
  21     [ " :" swap 3append ] when* "JOIN " prepend irc-print ;
  22
  23 : (connect-irc) ( -- )
  24     irc> {
  25         [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
  26         [ (>>stream) ]
  27         [ t swap (>>is-running) ]
  28         [ in-messages>> [ irc-connected ] dip mailbox-put ]
  29     } cleave ;
  30
  31 : (do-login) ( -- ) irc> nick>> /LOGIN ;
  32
  33 GENERIC: initialize-chat ( chat -- )
  34 M: irc-chat         initialize-chat drop ;
  35 M: irc-channel-chat initialize-chat [ name>> ] [ password>> ] bi /JOIN ;
  36
  37 GENERIC: chat-put ( message obj -- )
  38 M: irc-chat chat-put in-messages>> mailbox-put ;
  39 M: symbol   chat-put chat> [ chat-put ] [ drop ] if* ;
  40 M: string   chat-put chat> +server-chat+ or chat-put ;
  41 M: sequence chat-put [ chat-put ] with each ;
  42
  43 : delete-chat ( name -- ) irc> chats>> delete-at ;
  44 : unregister-chat ( name -- ) [ irc-chat-end chat-put ] [ delete-chat ] bi ;
  45
  46 ! Server message handling
  47
  48 GENERIC: forward-message ( irc-message -- )
  49 M: irc-message   forward-message +server-chat+ chat-put ;
  50 M: to-one-chat   forward-message dup chat> chat-put ;
  51 M: to-all-chats  forward-message chats> chat-put ;
  52 M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
  53
  54 GENERIC: process-message ( irc-message -- )
  55 M: object process-message drop ;
  56 M: ping   process-message trailing>> /PONG ;
  57 M: join   process-message [ sender>> ] [ chat> ] bi join-participant ;
  58 M: part   process-message [ sender>> ] [ chat> ] bi part-participant ;
  59 M: quit   process-message sender>> quit-participant ;
  60 M: nick   process-message [ trailing>> ] [ sender>> ] bi rename-participant* ;
  61 M: rpl-nickname-in-use process-message name>> "_" append /NICK ;
  62
  63 M: rpl-welcome process-message
  64     irc>
  65         swap nickname>> >>nick
  66         t >>is-ready
  67     chats>> values [ initialize-chat ] each ;
  68
  69 M: kick process-message
  70     [ [ user>> ] [ chat> ] bi part-participant ]
  71     [ dup user>> me? [ unregister-chat ] [ drop ] if ]
  72     bi ;
  73
  74 M: participant-mode process-message ( participant-mode -- )
  75     [ mode>> ] [ name>> ] [ parameter>> ] tri change-participant-mode ;
  76
  77 M: rpl-names process-message
  78     [ nicks>> ] [ chat> ] bi dup ?clear-participants
  79     '[ _ join-participant ] each ;
  80
  81 M: rpl-names-end process-message chat> t >>clear-participants drop ;
  82
  83 ! Client message handling
  84
  85 GENERIC: handle-outgoing-irc ( irc-message -- ? )
  86 M: irc-end     handle-outgoing-irc drop f ;
  87 M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
  88
  89 ! Reader/Writer
  90
  91 : handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
  92
  93 : (handle-disconnect) ( -- )
  94     irc-disconnected irc> in-messages>> mailbox-put
  95     irc> reconnect-time>> sleep
  96     (connect-irc)
  97     (do-login) ;
  98
  99 : handle-disconnect ( error -- ? )
 100     [ irc> exceptions>> push ] when*
 101     irc> is-running>> [ (handle-disconnect) t ] [ f ] if ;
 102
 103 GENERIC: handle-input ( line/f -- ? )
 104 M: string handle-input string>irc-message handle-reader-message t ;
 105 M: f      handle-input handle-disconnect ;
 106
 107 : (reader-loop) ( -- ? )
 108     stream> [ |dispose stream-readln handle-input ] with-destructors ;
 109
 110 : reader-loop ( -- ? ) [ (reader-loop) ] [ handle-disconnect ] recover ;
 111 : writer-loop ( -- ? ) irc> out-messages>> mailbox-get handle-outgoing-irc ;
 112
 113 ! Processing loops
 114
 115 : in-multiplexer-loop ( -- ? )
 116     irc> in-messages>> mailbox-get
 117     [ process-message ] [ forward-message ] [ irc-end? not ] tri ;
 118
 119 : strings>privmsg ( name string -- privmsg )
 120     " :" prepend append "PRIVMSG " prepend string>irc-message ;
 121
 122 GENERIC: annotate-message ( chat object -- object )
 123 M: object     annotate-message nip ;
 124 M: to-channel annotate-message swap name>> >>channel ;
 125 M: to-target  annotate-message swap name>> >>target ;
 126 M: mode       annotate-message swap name>> >>name ;
 127 M: string     annotate-message [ name>> ] dip strings>privmsg ;
 128
 129 : spawn-irc ( -- )
 130     [ reader-loop ] "irc-reader-loop" spawn-server
 131     [ writer-loop ] "irc-writer-loop" spawn-server
 132     [ in-multiplexer-loop ] "in-multiplexer-loop" spawn-server
 133     3drop ;
 134
 135 GENERIC: (attach-chat) ( irc-chat -- )
 136
 137 M: irc-chat (attach-chat)
 138     irc>
 139     [ [ chats>> ] [ >>client name>> swap ] 2bi set-at ]
 140     [ is-ready>> [ initialize-chat ] [ drop ] if ]
 141     2bi ;
 142
 143 M: irc-server-chat (attach-chat)
 144     irc> [ (>>client) ] [ chats>> +server-chat+ set-at ] 2bi ;
 145
 146 GENERIC: remove-chat ( irc-chat -- )
 147 M: irc-nick-chat remove-chat name>> unregister-chat ;
 148 M: irc-server-chat remove-chat drop +server-chat+ unregister-chat ;
 149
 150 M: irc-channel-chat remove-chat
 151     [ part new annotate-message irc-send ]
 152     [ name>> unregister-chat ] bi ;
 153
 154 : (terminate-irc) ( -- )
 155     irc> dup is-running>> [
 156         f >>is-running
 157         [ stream>> dispose ] keep
 158         [ in-messages>> ] [ out-messages>> ] bi 2array
 159         [ irc-end swap mailbox-put ] each
 160     ] [ drop ] if ;
 161
 162 : (speak) ( message irc-chat -- ) swap annotate-message irc-send ;