extra/irc/irc.factor

   1 ! Copyright (C) 2007 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays calendar io io.sockets kernel match namespaces
   4 sequences splitting strings continuations threads ;
   5 IN: irc
   6
   7 ! "setup" objects
   8 TUPLE: profile server port nickname password default-channels ;
   9 C: <profile> profile
  10
  11 TUPLE: channel-profile name password auto-rejoin ;
  12 C: <channel-profile> channel-profile
  13
  14 ! "live" objects
  15 TUPLE: irc-client profile nick stream stream-process controller-process ;
  16 C: <irc-client> irc-client
  17
  18 TUPLE: nick name channels log ;
  19 C: <nick> nick
  20
  21 TUPLE: channel name topic members log attributes ;
  22 C: <channel> channel
  23
  24 ! the delegate of all irc messages
  25 TUPLE: irc-message timestamp ;
  26 C: <irc-message> irc-message
  27
  28 ! "irc message" objects
  29 TUPLE: logged-in name text ;
  30 C: <logged-in> logged-in
  31
  32 TUPLE: ping name ;
  33 C: <ping> ping
  34
  35 TUPLE: join name channel ;
  36 C: <join> join
  37
  38 TUPLE: part name channel text ;
  39 C: <part> part
  40
  41 TUPLE: quit text ;
  42 C: <quit> quit
  43
  44 TUPLE: privmsg name text ;
  45 C: <privmsg> privmsg
  46
  47 TUPLE: kick channel er ee text ;
  48 C: <kick> kick
  49
  50 TUPLE: roomlist channel names ;
  51 C: <roomlist> roomlist
  52
  53 TUPLE: nick-in-use name ;
  54 C: <nick-in-use> nick-in-use
  55
  56 TUPLE: notice type text ;
  57 C: <notice> notice
  58
  59 TUPLE: mode name channel mode text ;
  60 C: <mode> mode
  61 ! TUPLE: members
  62
  63 TUPLE: unhandled text ;
  64 C: <unhandled> unhandled
  65
  66 ! "control message" objects
  67 TUPLE: command sender ;
  68 TUPLE: service predicate quot enabled? ;
  69 TUPLE: chat-command from to text ;
  70 TUPLE: join-command channel password ;
  71 TUPLE: part-command channel text ;
  72
  73 SYMBOL: irc-client
  74 : irc-stream> ( -- stream ) irc-client get irc-client-stream ;
  75 : trim-: ( seq -- seq ) [ CHAR: : = ] ltrim ;
  76 : parse-name ( string -- string )
  77     trim-: "!" split first ;
  78 : irc-split ( string -- seq )
  79     1 swap [ [ CHAR: : = ] find* ] keep
  80     swap [ cut trim-: ] [ nip f ] if >r [ blank? ] trim trim-:
  81     " " split r> [ 1array append ] when* ;
  82 : me? ( name -- ? )
  83     irc-client get irc-client-nick nick-name = ;
  84
  85 : irc-write ( s -- )
  86     irc-stream> stream-write ;
  87
  88 : irc-print ( s -- )
  89     irc-stream> [ stream-print ] keep stream-flush ;
  90
  91 : nick ( nick -- )
  92     "NICK " irc-write irc-print ;
  93
  94 : login ( nick -- )
  95     dup nick
  96     "USER " irc-write irc-write
  97     " hostname servername :irc.factor" irc-print ;
  98
  99 : connect* ( server port -- )
 100     <inet> <client> irc-client get set-irc-client-stream ;
 101
 102 : connect ( server -- ) 6667 connect* ;
 103
 104 : join ( channel password -- )
 105     "JOIN " irc-write
 106     [ >r " :" r> 3append ] when* irc-print ;
 107
 108 : part ( channel text -- )
 109     >r "PART " irc-write irc-write r>
 110     " :" irc-write irc-print ;
 111
 112 : say ( line nick -- )
 113     "PRIVMSG " irc-write irc-write " :" irc-write irc-print ;
 114
 115 : quit ( text -- )
 116     "QUIT :" irc-write irc-print ;
 117
 118
 119 GENERIC: handle-irc ( obj -- )
 120
 121 M: object handle-irc ( obj -- )
 122     "Unhandled irc object" print drop ;
 123
 124 M: logged-in handle-irc ( obj -- )
 125     logged-in-name irc-client get [ irc-client-nick set-nick-name ] keep
 126
 127     irc-client-profile profile-default-channels
 128     [
 129         [ channel-profile-name ] keep
 130         channel-profile-password join
 131     ] each ;
 132
 133 M: ping handle-irc ( obj -- )
 134     "PONG " irc-write
 135     ping-name irc-print ;
 136
 137 M: nick-in-use handle-irc ( obj -- )
 138     nick-in-use-name "_" append nick ;
 139
 140 : delegate-timestamp ( obj -- obj )
 141     now <irc-message> over set-delegate ;
 142
 143 MATCH-VARS: ?name ?name2 ?channel ?text ?mode ;
 144 SYMBOL: line
 145 : match-irc ( string -- )
 146     dup line set
 147     dup print flush
 148     irc-split
 149     {
 150         { { "PING" ?name }
 151           [ ?name <ping> ] }
 152         { { ?name "001" ?name2 ?text }
 153           [ ?name2 ?text <logged-in> ] }
 154         { { ?name "433" _ ?name2 "Nickname is already in use." }
 155           [ ?name2 <nick-in-use> ] }
 156
 157         { { ?name "JOIN" ?channel }
 158           [ ?name ?channel <join> ] }
 159         { { ?name "PART" ?channel ?text }
 160           [ ?name ?channel ?text <part> ] }
 161         { { ?name "PRIVMSG" ?channel ?text }
 162           [ ?name ?channel ?text <privmsg> ] }
 163         { { ?name "QUIT" ?text }
 164           [ ?name ?text <quit> ] }
 165
 166         { { "NOTICE" ?name ?text }
 167           [ ?name ?text <notice> ] }
 168         { { ?name "MODE" ?channel ?mode ?text }
 169           [ ?name ?channel ?mode ?text <mode> ] }
 170         { { ?name "KICK" ?channel ?name2 ?text }
 171           [  ?channel ?name ?name2 ?text <kick> ] }
 172
 173         ! { { ?name "353" ?name2 _ ?channel ?text }
 174          ! [ ?text ?channel ?name2 make-member-list ] }
 175         { _ [ line get <unhandled> ] }
 176     } match-cond
 177     delegate-timestamp handle-irc flush ;
 178
 179 : irc-loop ( -- )
 180     irc-stream> stream-readln
 181     [ match-irc irc-loop ] when* ;
 182
 183 : do-irc ( irc-client -- )
 184     dup irc-client set
 185     dup irc-client-profile profile-server
 186     over irc-client-profile profile-port connect*
 187     dup irc-client-profile profile-nickname login
 188     [ irc-loop ] [ irc-stream> stream-close ] [ ] cleanup ;
 189
 190 : with-infinite-loop ( quot timeout -- quot timeout )
 191     "looping" print flush
 192     over catch drop dup sleep with-infinite-loop ;
 193
 194 : start-irc ( irc-client -- )
 195     ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ;
 196     [ do-irc ] curry 3000 with-infinite-loop ;
 197
 198
 199 ! For testing
 200 : make-factorbot
 201     "irc.freenode.org" 6667 "factorbot" f
 202     [
 203         "#concatenative-flood" f f <channel-profile> ,
 204     ] { } make <profile>
 205     f V{ } clone V{ } clone <nick>
 206     f f f <irc-client> ;
 207
 208 : test-factorbot
 209     make-factorbot start-irc ;
 210