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
   4        arrays classes.tuple math.order ;
   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 name ;
  20 TUPLE: notice < irc-message type ;
  21 TUPLE: mode < irc-message name mode parameter ;
  22 TUPLE: names-reply < irc-message who channel ;
  23 TUPLE: end-of-names < irc-message who channel ;
  24 TUPLE: unhandled < irc-message ;
  25
  26 : <irc-client-message> ( command parameters trailing -- irc-message )
  27     irc-message new
  28         now >>timestamp
  29         swap >>trailing
  30         swap >>parameters
  31         swap >>command ;
  32
  33 <PRIVATE
  34
  35 GENERIC: command-string>> ( irc-message -- string )
  36
  37 M: irc-message command-string>> ( irc-message -- string ) command>> ;
  38 M: ping        command-string>> ( ping -- string )    drop "PING" ;
  39 M: join        command-string>> ( join -- string )    drop "JOIN" ;
  40 M: part        command-string>> ( part -- string )    drop "PART" ;
  41 M: quit        command-string>> ( quit -- string )    drop "QUIT" ;
  42 M: nick        command-string>> ( nick -- string )    drop "NICK" ;
  43 M: privmsg     command-string>> ( privmsg -- string ) drop "PRIVMSG" ;
  44 M: notice      command-string>> ( notice -- string )  drop "NOTICE" ;
  45 M: mode        command-string>> ( mode -- string )    drop "MODE" ;
  46 M: kick        command-string>> ( kick -- string )    drop "KICK" ;
  47
  48 GENERIC: command-parameters>> ( irc-message -- seq )
  49
  50 M: irc-message command-parameters>> ( irc-message -- seq ) parameters>> ;
  51 M: ping        command-parameters>> ( ping -- seq )    drop { } ;
  52 M: join        command-parameters>> ( join -- seq )    drop { } ;
  53 M: part        command-parameters>> ( part -- seq )    channel>> 1array ;
  54 M: quit        command-parameters>> ( quit -- seq )    drop { } ;
  55 M: nick        command-parameters>> ( nick -- seq )    drop { } ;
  56 M: privmsg     command-parameters>> ( privmsg -- seq ) name>> 1array ;
  57 M: notice      command-parameters>> ( norice -- seq )  type>> 1array ;
  58 M: kick command-parameters>> ( kick -- seq )
  59     [ channel>> ] [ who>> ] bi 2array ;
  60 M: mode command-parameters>> ( mode -- seq )
  61     [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
  62
  63 GENERIC# >>command-parameters 1 ( irc-message params -- irc-message )
  64
  65 M: irc-message >>command-parameters ( irc-message params -- irc-message )
  66     drop ;
  67
  68 M: logged-in >>command-parameters ( part params -- part )
  69     first >>name ;
  70
  71 M: privmsg >>command-parameters ( privmsg params -- privmsg )
  72     first >>name ;
  73
  74 M: notice >>command-parameters ( notice params -- notice )
  75     first >>type ;
  76
  77 M: part >>command-parameters ( part params -- part )
  78     first >>channel ;
  79
  80 M: kick >>command-parameters ( kick params -- kick )
  81     first2 [ >>channel ] [ >>who ] bi* ;
  82
  83 M: nick-in-use >>command-parameters ( nick-in-use params -- nick-in-use )
  84     second >>name ;
  85
  86 M: names-reply >>command-parameters ( names-reply params -- names-reply )
  87     first3 nip [ >>who ] [ >>channel ] bi* ;
  88
  89 M: end-of-names >>command-parameters ( names-reply params -- names-reply )
  90     first2 [ >>who ] [ >>channel ] bi* ;
  91
  92 M: mode >>command-parameters ( mode params -- mode )
  93     dup length {
  94         { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
  95         { 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
  96         [ drop first >>name dup trailing>> >>mode ]
  97     } case ;
  98
  99 PRIVATE>
 100
 101 GENERIC: irc-message>client-line ( irc-message -- string )
 102
 103 M: irc-message irc-message>client-line ( irc-message -- string )
 104     [ command-string>> ]
 105     [ command-parameters>> " " sjoin ]
 106     [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
 107     tri 3array " " sjoin ;
 108
 109 GENERIC: irc-message>server-line ( irc-message -- string )
 110
 111 M: irc-message irc-message>server-line ( irc-message -- string )
 112    drop "not implemented yet" ;
 113
 114 <PRIVATE
 115
 116 ! ======================================
 117 ! Message parsing
 118 ! ======================================
 119
 120 : split-at-first ( seq separators -- before after )
 121     dupd '[ _ member? ] find [ cut 1 tail ] [ swap ] if ;
 122
 123 : remove-heading-: ( seq -- seq )
 124     ":" ?head drop ;
 125
 126 : parse-name ( string -- string )
 127     remove-heading-: "!" split-at-first drop ;
 128
 129 : split-prefix ( string -- string/f string )
 130     dup ":" head?
 131     [ remove-heading-: " " split1 ] [ f swap ] if ;
 132
 133 : split-trailing ( string -- string string/f )
 134     ":" split1 ;
 135
 136 : copy-message-in ( command irc-message -- command )
 137     {
 138         [ line>>      >>line ]
 139         [ prefix>>    >>prefix ]
 140         [ command>>   >>command ]
 141         [ trailing>>  >>trailing ]
 142         [ timestamp>> >>timestamp ]
 143         [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
 144     } cleave ;
 145
 146 PRIVATE>
 147
 148 UNION: sender-in-prefix privmsg join part quit kick mode nick ;
 149 GENERIC: irc-message-sender ( irc-message -- sender )
 150 M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
 151     prefix>> parse-name ;
 152
 153 : string>irc-message ( string -- object )
 154     dup split-prefix split-trailing
 155     [ [ blank? ] trim " " split unclip swap ] dip
 156     now irc-message boa ;
 157
 158 : irc-message>command ( irc-message -- command )
 159     [
 160         command>> {
 161             { "PING"    [ ping ] }
 162             { "NOTICE"  [ notice ] }
 163             { "001"     [ logged-in ] }
 164             { "433"     [ nick-in-use ] }
 165             { "353"     [ names-reply ] }
 166             { "366"     [ end-of-names ] }
 167             { "JOIN"    [ join ] }
 168             { "PART"    [ part ] }
 169             { "NICK"    [ nick ] }
 170             { "PRIVMSG" [ privmsg ] }
 171             { "QUIT"    [ quit ] }
 172             { "MODE"    [ mode ] }
 173             { "KICK"    [ kick ] }
 174             [ drop unhandled ]
 175         } case new
 176     ] keep copy-message-in ;
 177
 178 : parse-irc-line ( string -- message )
 179     string>irc-message irc-message>command ;