extra/irc/messages/messages.factor

   1 ! Copyright (C) 2008 Bruno Deferrari
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel fry splitting ascii calendar accessors combinators qualified
   4        arrays classes.tuple math.order quotations ;
   5 RENAME: join sequences => sjoin
   6 EXCLUDE: sequences => join ;
   7 IN: irc.messages
   8
   9 TUPLE: irc-message line prefix command parameters trailing timestamp ;
  10 TUPLE: logged-in < irc-message name ;
  11 TUPLE: ping < irc-message ;
  12 TUPLE: join < irc-message ;
  13 TUPLE: part < irc-message channel ;
  14 TUPLE: quit < irc-message ;
  15 TUPLE: nick < irc-message ;
  16 TUPLE: privmsg < irc-message name ;
  17 TUPLE: kick < irc-message channel who ;
  18 TUPLE: roomlist < irc-message channel names ;
  19 TUPLE: nick-in-use < irc-message asterisk name ;
  20 TUPLE: notice < irc-message type ;
  21 TUPLE: mode < irc-message channel mode nickname parameter ;
  22 TUPLE: names-reply < irc-message who channel ;
  23 TUPLE: unhandled < irc-message ;
  24
  25 : <irc-client-message> ( command parameters trailing -- irc-message )
  26     irc-message new now >>timestamp
  27     [ [ (>>trailing) ] [ (>>parameters) ] [ (>>command) ] tri ] keep ;
  28
  29 <PRIVATE
  30
  31 : channel? ( string -- ? )
  32     first "#&" member? ;
  33
  34 GENERIC: command-string>> ( irc-message -- string )
  35
  36 M: irc-message command-string>> ( irc-message -- string ) command>> ;
  37 M: ping        command-string>> ( ping -- string )    drop "PING" ;
  38 M: join        command-string>> ( join -- string )    drop "JOIN" ;
  39 M: part        command-string>> ( part -- string )    drop "PART" ;
  40 M: quit        command-string>> ( quit -- string )    drop "QUIT" ;
  41 M: nick        command-string>> ( nick -- string )    drop "NICK" ;
  42 M: privmsg     command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
  43 M: notice      command-string>> ( notice -- string )  drop "NOTICE" ;
  44 M: mode        command-string>> ( mode -- string )    drop "MODE" ;
  45 M: kick        command-string>> ( kick -- string )    drop "KICK" ;
  46
  47 GENERIC: command-parameters>> ( irc-message -- seq )
  48
  49 M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
  50 M: ping        command-parameters>> ( ping -- seq )    drop { } ;
  51 M: join        command-parameters>> ( join -- seq )    drop { } ;
  52 M: part        command-parameters>> ( part -- seq )    channel>> 1array ;
  53 M: quit        command-parameters>> ( quit -- seq )    drop { } ;
  54 M: nick        command-parameters>> ( nick -- seq )    drop { } ;
  55 M: privmsg     command-parameters>> ( privmsg -- seq ) name>> 1array ;
  56 M: notice      command-parameters>> ( norice -- seq )  type>> 1array ;
  57 M: kick command-parameters>> ( kick -- seq )
  58     [ channel>> ] [ who>> ] bi 2array ;
  59 M: mode command-parameters>> ( mode -- seq )
  60     [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
  61
  62 GENERIC: (>>command-parameters) ( params irc-message -- )
  63
  64 M: irc-message (>>command-parameters) ( params irc-message -- ) 2drop ;
  65 M: logged-in (>>command-parameters) ( params part -- )  >r first r> (>>name) ;
  66 M: part    (>>command-parameters) ( params part -- )    >r first r> (>>channel) ;
  67 M: privmsg (>>command-parameters) ( params privmsg -- ) >r first r> (>>name) ;
  68 M: notice  (>>command-parameters) ( params notice -- )  >r first r> (>>type) ;
  69 M: kick    (>>command-parameters) ( params kick -- )
  70     >r first2 r> [ (>>who) ] [ (>>channel) ] bi ;
  71 M: names-reply (>>command-parameters) ( params names-reply -- )
  72     [ >r first r> (>>who) ] [ >r third r> (>>channel) ] 2bi ;
  73 M: mode    (>>command-parameters) ( params mode -- )
  74     over first channel? [
  75         over length 3 = [
  76             >r first3 r> [ (>>parameter) ] [ (>>mode) ] [ (>>channel) ] tri
  77         ] [
  78             >r first2 r>                   [ (>>mode) ] [ (>>channel) ] bi
  79         ] if
  80     ] [
  81         >r first2 r> [ (>>mode) ] [ (>>nickname) ] bi
  82     ] if ;
  83
  84 PRIVATE>
  85
  86 GENERIC: irc-message>client-line ( irc-message -- string )
  87
  88 M: irc-message irc-message>client-line ( irc-message -- string )
  89     [ command-string>> ]
  90     [ command-parameters>> " " sjoin ]
  91     [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
  92     tri 3array " " sjoin ;
  93
  94 GENERIC: irc-message>server-line ( irc-message -- string )
  95
  96 M: irc-message irc-message>server-line ( irc-message -- string )
  97    drop "not implemented yet" ;
  98
  99 <PRIVATE
 100 ! ======================================
 101 ! Message parsing
 102 ! ======================================
 103
 104 : split-at-first ( seq separators -- before after )
 105     dupd '[ , member? ] find
 106         [ cut 1 tail ]
 107         [ swap ]
 108     if ;
 109
 110 : remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
 111
 112 : parse-name ( string -- string )
 113     remove-heading-: "!" split-at-first drop ;
 114
 115 : split-prefix ( string -- string/f string )
 116     dup ":" head?
 117         [ remove-heading-: " " split1 ]
 118         [ f swap ]
 119     if ;
 120
 121 : split-trailing ( string -- string string/f )
 122     ":" split1 ;
 123
 124 : copy-message-in ( origin dest -- )
 125     { [ >r parameters>> r> [ (>>command-parameters) ] [ (>>parameters) ] 2bi ]
 126       [ >r line>>       r> (>>line) ]
 127       [ >r prefix>>     r> (>>prefix) ]
 128       [ >r command>>    r> (>>command) ]
 129       [ >r trailing>>   r> (>>trailing) ]
 130       [ >r timestamp>>  r> (>>timestamp) ]
 131     } 2cleave ;
 132
 133 PRIVATE>
 134
 135 UNION: sender-in-prefix privmsg join part quit kick mode nick ;
 136 GENERIC: irc-message-sender ( irc-message -- sender )
 137 M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
 138     prefix>> parse-name ;
 139
 140 : string>irc-message ( string -- object )
 141     dup split-prefix split-trailing
 142     [ [ blank? ] trim " " split unclip swap ] dip
 143     now irc-message boa ;
 144
 145 : parse-irc-line ( string -- message )
 146     string>irc-message
 147     dup command>> {
 148         { "PING"    [ ping ] }
 149         { "NOTICE"  [ notice ] }
 150         { "001"     [ logged-in ] }
 151         { "433"     [ nick-in-use ] }
 152         { "353"     [ names-reply ] }
 153         { "JOIN"    [ join ] }
 154         { "PART"    [ part ] }
 155         { "NICK"    [ nick ] }
 156         { "PRIVMSG" [ privmsg ] }
 157         { "QUIT"    [ quit ] }
 158         { "MODE"    [ mode ] }
 159         { "KICK"    [ kick ] }
 160         [ drop unhandled ]
 161     } case new [ copy-message-in ] keep ;