unmaintained/irc/irc-client.factor

   1 USING: arrays calendar concurrency errors generic hashtables
   2 help html http io kernel match math memory namespaces
   3 parser prettyprint quotations sequences sequences-contrib
   4 splay-trees strings threads words network ;
   5 IN: irc
   6
   7 ! "setup" objects
   8 TUPLE: profile server port nickname password default-channels ;
   9 TUPLE: channel-profile name password auto-rejoin ;
  10
  11 ! "live" objects
  12 TUPLE: irc-client profile nick stream stream-process controller-process ;
  13 TUPLE: nick name channels log ;
  14 TUPLE: channel name topic members log attributes ;
  15
  16 ! "irc message" objects
  17   ! the delegate of all irc messages
  18 TUPLE: irc-message timestamp ;
  19 TUPLE: logged-in name text ;
  20 TUPLE: ping name ;
  21 TUPLE: join name channel ;
  22 TUPLE: part name channel text ;
  23 TUPLE: quit text ;
  24
  25 TUPLE: privmsg name text ;
  26 TUPLE: kick channel er ee text ;
  27 TUPLE: roomlist channel names ;
  28 TUPLE: nick-in-use name ;
  29 TUPLE: notice type text ;
  30 TUPLE: mode name channel mode text ;
  31 ! TUPLE: members
  32
  33 TUPLE: unhandled text ;
  34
  35 ! "control message" objects
  36 TUPLE: command sender ;
  37 TUPLE: service predicate quot enabled? ;
  38 TUPLE: chat-command from to text ;
  39 TUPLE: join-command channel password ;
  40 TUPLE: part-command channel text ;
  41
  42 SYMBOL: irc-client
  43 : irc-stream> ( -- stream ) irc-client get irc-client-stream ;
  44 : trim-: ( seq -- seq ) [ CHAR: : = ] ltrim* ;
  45 : parse-name ( string -- string )
  46     trim-: "!" split first ;
  47 : irc-split ( string -- seq )
  48     1 swap [ [ CHAR: : = ] find* ] keep
  49     swap [ cut trim-: ] [ nip f ] if >r trim trim-:
  50     " " split r> [ 1array append ] when* ;
  51 : me? ( name -- ? )
  52     irc-client get irc-client-nick nick-name = ;
  53
  54 : irc-write ( s -- )
  55     irc-stream> stream-write ;
  56
  57 : irc-print ( s -- )
  58     irc-stream> [ stream-print ] keep stream-flush ;
  59
  60 : nick ( nick -- )
  61     "NICK " irc-write irc-print ;
  62
  63 : login ( nick -- )
  64     dup nick
  65     "USER " irc-write irc-write
  66     " hostname servername :irc.factor" irc-print ;
  67
  68 : connect* ( server port -- )
  69     <inet> <client> irc-client get set-irc-client-stream ;
  70
  71 : connect ( server -- ) 6667 connect* ;
  72
  73 : join ( channel password -- )
  74     "JOIN " irc-write
  75     [ >r " :" r> 3append ] when* irc-print ;
  76
  77 : part ( channel text -- )
  78     >r "PART " irc-write irc-write r>
  79     " :" irc-write irc-print ;
  80
  81 : say ( line nick -- )
  82     "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
  83
  84 : quit ( text -- )
  85     "QUIT :" irc-write irc-print ;
  86
  87
  88 GENERIC: handle-irc ( obj -- )
  89
  90 M: object handle-irc ( obj -- )
  91     "Unhandled irc object" print drop ;
  92
  93 M: logged-in handle-irc ( obj -- )
  94     logged-in-name irc-client get [ irc-client-nick set-nick-name ] keep
  95
  96     irc-client-profile profile-default-channels
  97     [
  98         [ channel-profile-name ] keep
  99         channel-profile-password join
 100     ] each ;
 101
 102 M: ping handle-irc ( obj -- )
 103     "PONG " irc-write
 104     ping-name irc-print ;
 105
 106 M: nick-in-use handle-irc ( obj -- )
 107     nick-in-use-name "_" append nick ;
 108
 109 : delegate-timestamp ( obj -- obj )
 110     now <irc-message> over set-delegate ;
 111
 112 MATCH-VARS: ?name ?name2 ?channel ?text ?mode ;
 113 SYMBOL: line
 114 : match-irc ( string -- )
 115     dup line set
 116     dup print flush
 117     irc-split
 118     {
 119         { { "PING" ?name }
 120           [ ?name <ping> ] }
 121         { { ?name "001" ?name2 ?text }
 122           [ ?name2 ?text <logged-in> ] }
 123         { { ?name "433" _ ?name2 "Nickname is already in use." }
 124           [ ?name2 <nick-in-use> ] }
 125
 126         { { ?name "JOIN" ?channel }
 127           [ ?name ?channel <join> ] }
 128         { { ?name "PART" ?channel ?text }
 129           [ ?name ?channel ?text <part> ] }
 130         { { ?name "PRIVMSG" ?channel ?text }
 131           [ ?name ?channel ?text <privmsg> ] }
 132         { { ?name "QUIT" ?text }
 133           [ ?name ?text <quit> ] }
 134
 135         { { "NOTICE" ?name ?text }
 136           [ ?name ?text <notice> ] }
 137         { { ?name "MODE" ?channel ?mode ?text }
 138           [ ?name ?channel ?mode ?text <mode> ] }
 139         { { ?name "KICK" ?channel ?name2 ?text }
 140           [  ?channel ?name ?name2 ?text <kick> ] }
 141
 142         ! { { ?name "353" ?name2 _ ?channel ?text }
 143          ! [ ?text ?channel ?name2 make-member-list ] }
 144         { _ [ line get <unhandled> ] }
 145     } match-cond
 146     delegate-timestamp handle-irc flush ;
 147
 148 : irc-loop ( -- )
 149     irc-stream> stream-readln
 150     [ match-irc irc-loop ] when* ;
 151
 152 : do-irc ( irc-client -- )
 153     dup irc-client set
 154     dup irc-client-profile profile-server
 155     over irc-client-profile profile-port connect*
 156     dup irc-client-profile profile-nickname login
 157     [ irc-loop ] [ irc-stream> stream-close ] cleanup ;
 158
 159 : with-infinite-loop ( quot timeout -- quot timeout )
 160     "looping" print flush
 161     over catch drop dup sleep with-infinite-loop ;
 162
 163 : start-irc ( irc-client -- )
 164     ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ;
 165     [ do-irc ] curry 3000 with-infinite-loop ;
 166
 167
 168 GENERIC: handle-command ( obj -- )
 169 : prepare-message ( from text -- string )
 170     >r dup [ >r "from " r> ": " 3append ] when r>
 171     append >string ;
 172
 173 M: chat-command handle-command ( obj -- )
 174     [ chat-command-from ] keep
 175     [ chat-command-text prepare-message ] keep
 176     chat-command-to say ;
 177
 178 M: join-command handle-command ( obj -- )
 179     [ join-command-channel ] keep
 180     join-command-password join ;
 181
 182 M: part-command handle-command ( obj -- )
 183     [ part-command-channel ] keep part-command-text part ;
 184
 185 M: service handle-command ( service -- )
 186     drop ;
 187
 188 : command-handler ( -- )
 189     receive [ handle-command ] catch [
 190         "error caught: " . flush
 191     ] when* command-handler ;
 192
 193 : send-command ( obj irc-client -- )
 194     >r self <command> over set-delegate r>
 195     irc-client-controller-process send ;
 196
 197 : subscribe-logger ( irc-client -- )
 198     >r "#concatenative-flood" "log" <service> r>
 199     send-command ;
 200
 201 ! : start-private ( irc-client -- )
 202     ! dup irc-client set [ start-irc ] spawn ;
 203
 204 : maybe-start-node ( port -- )
 205     \ localnode get [
 206         drop
 207     ] [
 208         >r "localhost" r> start-node
 209     ] if ;
 210
 211 : start-public ( irc-client id -- )
 212     [
 213         >r
 214             dup irc-client set
 215             4030 maybe-start-node
 216             [ command-handler ] spawn
 217         r> over register-process
 218         swap [ set-irc-client-controller-process ] keep
 219         [ [ start-irc ] spawn ] keep set-irc-client-stream-process
 220     ] with-scope ;
 221
 222 ! "trifocus.net" 4030 <node> "public-irc" <remote-process> "guest" "#concatenative" "hi" <chat-command> over send
 223
 224 : make-test-client
 225     "irc.freenode.org"
 226         6667
 227         "factorbot2"
 228         f
 229         [
 230             "#concatenative-flood" f f <channel-profile> ,
 231             ! "#concatenative-test1" f f <channel-profile> ,
 232             ! "#concatenative-test2" f f <channel-profile> ,
 233             ! "#concatenative" f f <channel-profile> ,
 234         ] { } make <profile>
 235     f V{ } clone V{ } clone <nick>
 236     f
 237     f
 238     f
 239     <irc-client> ;
 240
 241 : test3 make-test-client "test3" start-public ;
 242 : test4 make-test-client "test4" start-public ;
 243 : test5 make-test-client "test5" start-public ;
 244 : test6 make-test-client "test6" start-public ;
 245
 246 : 3test { test3 test4 test5 } [ execute ] each ;
 247
 248 : make-furnacebot
 249     "irc.freenode.org"
 250         6667
 251         "furnacebot"
 252         f
 253         [
 254             "#concatenative" f f <channel-profile> ,
 255         ] { } make <profile>
 256     f V{ } clone V{ } clone <nick>
 257     f
 258     f
 259     f
 260     <irc-client> ;
 261
 262 : furnacebot
 263     make-furnacebot "public-irc" start-public ;
 264