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