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 ;
  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 GENERIC: irc-command-string ( irc-message -- string )
  32
  33 M: irc-message irc-command-string ( irc-message -- string ) command>> ;
  34 M: ping        irc-command-string ( ping -- string )    drop "PING" ;
  35 M: join        irc-command-string ( join -- string )    drop "JOIN" ;
  36 M: part        irc-command-string ( part -- string )    drop "PART" ;
  37 M: quit        irc-command-string ( quit -- string )    drop "QUIT" ;
  38 M: nick        irc-command-string ( nick -- string )    drop "NICK" ;
  39 M: privmsg     irc-command-string ( privmsg -- string ) drop "PRIVMSG" ;
  40 M: notice      irc-command-string ( notice -- string )  drop "NOTICE" ;
  41 M: mode        irc-command-string ( mode -- string )    drop "MODE" ;
  42 M: kick        irc-command-string ( kick -- string )    drop "KICK" ;
  43
  44 GENERIC: irc-command-parameters ( irc-message -- seq )
  45
  46 M: irc-message irc-command-parameters ( irc-message -- seq ) parameters>> ;
  47 M: ping        irc-command-parameters ( ping -- seq )    drop { } ;
  48 M: join        irc-command-parameters ( join -- seq )    drop { } ;
  49 M: part        irc-command-parameters ( part -- seq )    channel>> 1array ;
  50 M: quit        irc-command-parameters ( quit -- seq )    drop { } ;
  51 M: nick        irc-command-parameters ( nick -- seq )    drop { } ;
  52 M: privmsg     irc-command-parameters ( privmsg -- seq ) name>> 1array ;
  53 M: notice      irc-command-parameters ( norice -- seq )  type>> 1array ;
  54 M: kick irc-command-parameters ( kick -- seq )
  55     [ channel>> ] [ who>> ] bi 2array ;
  56 M: mode irc-command-parameters ( mode -- seq )
  57     [ name>> ] [ channel>> ] [ mode>> ] tri 3array ;
  58
  59 PRIVATE>
  60
  61 GENERIC: irc-message>client-line ( irc-message -- string )
  62
  63 M: irc-message irc-message>client-line ( irc-message -- string )
  64     [ irc-command-string ]
  65     [ irc-command-parameters " " sjoin ]
  66     [ trailing>> [ CHAR: : prefix ] [ "" ] if* ]
  67     tri 3array " " sjoin ;
  68
  69 GENERIC: irc-message>server-line ( irc-message -- string )
  70
  71 M: irc-message irc-message>server-line ( irc-message -- string )
  72    drop "not implemented yet" ;
  73
  74 <PRIVATE
  75 ! ======================================
  76 ! Message parsing
  77 ! ======================================
  78
  79 : split-at-first ( seq separators -- before after )
  80     dupd '[ _ member? ] find
  81         [ cut 1 tail ]
  82         [ swap ]
  83     if ;
  84
  85 : remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ;
  86
  87 : parse-name ( string -- string )
  88     remove-heading-: "!" split-at-first drop ;
  89
  90 : split-prefix ( string -- string/f string )
  91     dup ":" head?
  92         [ remove-heading-: " " split1 ]
  93         [ f swap ]
  94     if ;
  95
  96 : split-trailing ( string -- string string/f )
  97     ":" split1 ;
  98
  99 PRIVATE>
 100
 101 UNION: sender-in-prefix privmsg join part quit kick mode nick ;
 102 GENERIC: irc-message-sender ( irc-message -- sender )
 103 M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
 104     prefix>> parse-name ;
 105
 106 : string>irc-message ( string -- object )
 107     dup split-prefix split-trailing
 108     [ [ blank? ] trim " " split unclip swap ] dip
 109     now irc-message boa ;
 110
 111 : parse-irc-line ( string -- message )
 112     string>irc-message
 113     dup command>> {
 114         { "PING" [ ping ] }
 115         { "NOTICE" [ notice ] }
 116         { "001" [ logged-in ] }
 117         { "433" [ nick-in-use ] }
 118         { "353" [ names-reply ] }
 119         { "JOIN" [ join ] }
 120         { "PART" [ part ] }
 121         { "NICK" [ nick ] }
 122         { "PRIVMSG" [ privmsg ] }
 123         { "QUIT" [ quit ] }
 124         { "MODE" [ mode ] }
 125         { "KICK" [ kick ] }
 126         [ drop unhandled ]
 127     } case
 128     [ [ tuple-slots ] [ parameters>> ] bi append ] dip
 129     [ all-slots over [ length ] bi@ min head >quotation ] keep
 130     '[ @ _ boa ] call ;