Author: dylan Date: 2004-08-08 18:46:47 -0400 (Sun, 08 Aug 2004) New Revision: 342
Added: trunk/docs/manual/buildlatex trunk/docs/manual/chap/commands.tex trunk/docs/manual/chap/formats.tex trunk/docs/manual/config.m4 trunk/docs/manual/haver.bib trunk/docs/manual/style.tex trunk/docs/protocol/formats.txt trunk/web/ Removed: trunk/docs/formats.txt Modified: trunk/docs/manual/ trunk/docs/manual/Makefile trunk/docs/manual/chap/ trunk/docs/manual/chap/concepts.tex trunk/docs/manual/chap/introduction.tex trunk/docs/manual/chap/protocol.tex trunk/docs/manual/haver.tex trunk/docs/manual/macros.tex trunk/jarverd/lib/Jarver/Connection.pm trunk/main/client/lib/Haver/Client/POE.pm trunk/main/server/lib/Haver/Server/Object.pm trunk/main/server/lib/Haver/Server/POE.pm trunk/main/server/lib/Haver/Server/POE/Commands.pm trunk/main/server/lib/Haver/Server/POE/Connection.pm trunk/web/clients/haver-gtk/haver-gtk-1.png trunk/web/clients/haver-gtk/haver-gtk-2.png trunk/web/images/1000-things.JPG trunk/web/images/debian-powered.png trunk/web/images/dot.png trunk/web/images/hope.png trunk/web/images/tt2-powered.png trunk/web/images/valid-xhtml10.png trunk/web/images/vim-created.png Log: Merged protocol-v4 into /trunk. Deleted: trunk/docs/formats.txt =================================================================== --- trunk/docs/formats.txt 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/docs/formats.txt 2004-08-08 22:46:47 UTC (rev 342) @@ -1,45 +0,0 @@ -This document describes various formats -that are used in haver servers and clients. - -== Dates, Times, and Time Zones. == - -The following describes Dates, Times, Datetimes, and Time zones. - -=== Dates === - -The format for dates is YYYY-MM-DD. - -For example, Jan 12th, 2009 is 2009-01-12. - -=== Times === - -The fomat for times is HH:MM:SS (or HH:MM:SS.NN, for time intervals -less than one second). - -HH is from 00 to 23, MM is -00 to 59, and SS is 00 to 59. -For example, four thirty in the afternoon -is 16:30:00. - - -=== Time zones === - -Time zones are one of the following: - 1. + or - time GMT, i.e. -08:00 - 2. A capitalized abbreviation, i.e. CST - -=== Complete Datetimes === - -A complete datetime is as follows: - -YYYY-MM-DD HH:MM:SS [TZONE] - -The [TZONE] is optional. - - - -== File Formats == - -The standard file format for config files is YAML. - -See: http://www.yaml.org/ Property changes on: trunk/docs/manual ___________________________________________________________________ Name: svn:ignore + *.aux *.pdf *.ps *.dvi *.log *.toc *.bbl *.blg Modified: trunk/docs/manual/Makefile =================================================================== --- trunk/docs/manual/Makefile 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/docs/manual/Makefile 2004-08-08 22:46:47 UTC (rev 342) @@ -1,18 +1,29 @@ -export RERUN=Rerun to get cross-references right +DRAFT=1 -CLEAN=-name '*.aux' \ + +clean=-name '*.aux' \ -or -name '*.log' \ -or -name '*.bbl' \ -or -name '*.blg' \ - -or -name '*.toc' + -or -name '*.toc' \ + -or -name 'config.tex' +base=haver +tex=$(wildcard chap/*.tex) $(filter-out haver.tex,$(wildcard *.tex)) haver.bib config.m4 -base=haver +ifdef DRAFT +ARGS += -f DRAFT +endif +ifdef COLOR +ARGS += -f COLOR +endif -all: dvi +all: + @echo "Probably you want to run make pdf or make dvi or make html" + dvi: $(base).dvi pdf: $(base).pdf @@ -21,33 +32,21 @@ clean: - find . \( $(CLEAN) \) -exec rm -v {} \; + find . \( $(clean) \) -exec rm -v {} \; + realclean: - -rm $(base).dvi + -rm $(base).dvi $(base).pdf -$(base).dvi: $(base).tex $(wildcard chap/*.tex) $(base).bbl - latex $< | tee dvi.log - -grep -q "$$RERUN" dvi.log && latex $< - rm dvi.log +$(base).dvi: $(base).tex $(tex) + ./buildlatex -f DVI $(ARGS) $< -$(base).bbl: $(base).bib - -if [ ! -e $(base).aux ]; then \ - latex $(base).tex; \ - rm $(base).dvi; \ - fi - bibtex $(base) +$(base).pdf: $(base).tex $(tex) + ./buildlatex -f PDF $(ARGS) -l pdflatex $< +#$(base)/$(base).html: $(base).tex $(tex) +# latex2html -local_icons -split 3 $< -$(base).pdf: $(base).tex $(wildcard chap/*.tex) $(base).bbl - pdflatex $< | tee pdf.log - -grep -q "$$RERUN" pdf.log && pdflatex $< - rm pdf.log - - -$(base)/$(base).html: $(base).tex $(wildcard chap/*.tex) $(base).bbl - latex2html -local_icons -split 3 $< - .PHONY: all clean dvi Copied: trunk/docs/manual/buildlatex (from rev 341, branches/protocol-v4/docs/manual/buildlatex) Property changes on: trunk/docs/manual/buildlatex ___________________________________________________________________ Name: svn:executable + * Property changes on: trunk/docs/manual/chap ___________________________________________________________________ Name: svn:ignore + *.aux Copied: trunk/docs/manual/chap/commands.tex (from rev 341, branches/protocol-v4/docs/manual/chap/commands.tex) Modified: trunk/docs/manual/chap/concepts.tex =================================================================== --- trunk/docs/manual/chap/concepts.tex 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/docs/manual/chap/concepts.tex 2004-08-08 22:46:47 UTC (rev 342) @@ -1,6 +1,18 @@ \chapter{Concepts} +WRITE SUMMARY HERE. + + +\section{Object Data} + +Describe per-object data. e.g. channel topics, +nicknames, away messages... + +\section{User IDs Are Not Nicks} + +UIDs are not nicknames... + WRITE ME. Copied: trunk/docs/manual/chap/formats.tex (from rev 341, branches/protocol-v4/docs/manual/chap/formats.tex) Modified: trunk/docs/manual/chap/introduction.tex =================================================================== --- trunk/docs/manual/chap/introduction.tex 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/docs/manual/chap/introduction.tex 2004-08-08 22:46:47 UTC (rev 342) @@ -1,35 +1,40 @@ \chapter{Introduction} Haver is a simple line based, tab delimited protocol. It is -not meant as a replacement to IRC\cite{rfc:1459}, \cite{jabber}, -or SILC\cite{silc}. +not meant as a replacement to IRC\cite{rfc:1459}, Jabber\cite{jabber}, +or SILC\cite{silc}. Nevertheless, it should be rather +less difficult to write clients for haver than the above mentioned protocols. -Nevertheless, it should be rather less difficult to write clients for -than the above mentioned protocols. +This protocol is being designed because current protocols are either +too limited (e.g. IRC) or too complicated (e.g. jabber, SILC) to extend +in playful and useless ways. Something simple and powerful needs to exist, +and this could very well be haver. \section{Servers} -The server routes messages to and from clients, -keeps track of permisions for each client, -and a associates various key-value pairs with each client -and channel. +A Haver server is almost, but not quite, entirely unlike chocolate. +While chocolate's main purpose is to delight with its delicious +taste, haver servers do not have any taste. +Instead, haver servers route messages (commands) to their clients, +and maintain data about their clients and channels. +Monolithic servers will do more than just this, and will handle many commands +internally. Micro-servers will offload this burden unto special service clients. + \section{Clients} -Clients are any programs that connect to the server. -There are several different types of clients, and each may have access to special features -of the server. +A Haver client sends and relieves commands from the server, basically. -Each client of a given type (which is its namespace) must have a unique id. That is to say, -each type and id combination must be unique. +Each client has an identifier (id) and a type (namespace). +Details on ids and namespaces can be found in Section~\ref{format.id}. -The format of identifiers and namespaces is defined in Section~\ref{sec:format.id}. +The functionality available to a client, what it is allowed to do, +is strongly influenced by the type of client it is. \subsection{Users} -The vast majority of clients will be representations of users. -Users are the chatters of the network. -They may be real people, bots, or GreenReaper. +The vast majority of clients will be users, which are representations +of either real people, bots, or even Helephants. Users may or may not require authorization, depending on if the user is registered or not. @@ -38,22 +43,22 @@ \subsection{Services} -Services add new protocol commands to the server, +Services may add new protocol commands to the server, and will typically require some form of authorization. -\subsubsection{Agents} - Services may produce virtual user-like entities to interact with -users. These are called agents, and are rather like privileged bots. +the real users. These are called agents, and are rather like privileged bots. +In addition, services may be allowed to extend ``virtual'' channels into +the server to allow different forms of server linking. + % cross-ref: Authoriztion. - \section{Channels} -Channels are collections of users, much like in IRC, -except they must be created by a server admin or by some other controlled means. -Channel ids (cids) follow the same rules as identifiers for client objects -as defined in section~\ref{sec:format.id}. +Channels are pretty much like they are on IRC, except their identifiers (channel ids, cids) +follow the same rules as identifiers for the other types of objects (users, services, etc). +They may either automagically created upon use, or channel creation can be restricted to privileged users. + Modified: trunk/docs/manual/chap/protocol.tex =================================================================== --- trunk/docs/manual/chap/protocol.tex 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/docs/manual/chap/protocol.tex 2004-08-08 22:46:47 UTC (rev 342) @@ -1,11 +1,6 @@ \chapter{Protocol} +\label{protocol} -The haver protocol is line based, plain text protocol -for real time Internet conferencing. -Parsing it is not unlike parsing tab separated field files. - -\section{Parsing} - The protocol is in the UTF-8 encoding, but only the first 127 character codes (ASCII) are used for commands, identifiers, and delimiters. @@ -14,7 +9,7 @@ have special meaning. CR (Carriage Return) followed by LF (Line Feed) terminates a line. Each line is subdivided into tokens separated by Tabs. Esc is used for encoding literal CR, LF, Tab, and Esc characters. -See Section~\ref{sec:esc} for details on escaping. +See Section~\ref{protocol.esc} for details on escaping. \begin{table} \caption{Special Characters} @@ -28,19 +23,19 @@ \end{tabular} \end{table} -\subsection{Lines} + \section{Parsing Lines} -Lines are terminated by the sequence CR LF, -which is a carriage return followed by a line feed. -A carriage return not followed by a line feed is illegal, -as is a line feed not preceded with a carriage return. -The previous sentence may be ignored for simplicity. + Lines are terminated by the sequence CR LF, + which is a carriage return followed by a line feed. + A carriage return not followed by a line feed is illegal, + as is a line feed not preceded with a carriage return. + The previous sentence may be ignored for simplicity. -Most programming languages have a fairly easy -way of reading lines from sockets. In perl, -the \function{readline} function should do. + Most programming languages have a fairly easy + way of reading lines from sockets. In perl, + the \function{readline} function should do. - \subsection{Lists} + \section{Parsing Lists} Each line is a list of strings separated by a Tab character. The first item in the list is generally called the command, @@ -50,8 +45,8 @@ to parse this. The C library glib (used by gtk) has a \function{g\_strsplit} function, as well. - \subsection{Escaping and Unescaping} - \label{sec:esc} + \section{Escaping and Unescaping} + \label{protocol.esc} Escape sequences are used to encode ``CR'', ``LF'', ``Tab'', and ``Esc'' (as defined in Table~\ref{tab:chars}) as ``Esc r'', ``Esc n'', ``Esc t'', and ``Esc e'' @@ -77,88 +72,8 @@ \end{tabular} \end{table} - \subsection{Psuedo-code Examples} + \section{Psuedo-code Examples} TODO. WRITE ME. -\section{Formats} -This section describes formats used in the haver protocol, -such as how dates, times, and time zones are formatted. -It also describes the format for identifiers (the ids of channels, users, etc). - -\subsection{Dates and Times} - -Haver dates are - -\begin{table} -\caption{Timestamp formats} -\label{tab:format.time} -\begin{tabular}{|l|l|} \hline -Symbolic Name & Perl Regex & Example\\ -\hline -\emph{Date} & \verb!/\d{4}-\d{2}-\d{2}/! & 1985-09-14 \\ -\hline -\emph{Time} & \verb!/\d{2}:\d{2}:\d{2}(\.\d+)?/! & 01:18:14 \\ -\hline -\emph{Timezone} & \verb!/[+-]\d{2}\d{2}/! & -0400 \\ -\hline -\end{tabular} -\end{table} - -An example time stamp would be 1944-06-06 12:30:41 +0100, -which is June 6th, 1944 at half past noon (and 41 seconds...) in the UTC + 1 -time zone. - - - -\subsubsection{Dates} -Dates are expressed as YYYY-MM-DD, which MM and DD are zero-padded if necessary. -For example would be 1985-09-14. - - -\subsubsection{Times} -Time is expressed as HH:MM:SS, where the hour ranges from 00 to 23, -the minute and second range from 00 to 59. -A period (``.'') me be appended to SS to express any fractional part of a second. - - -\subsubsection{Time Zones} - -All times are assumed to be in UTC unless a different time zone is specified. -The format for time zones is ZHHMM, where Z is either a plus or a minus sign, -HH the hour offset and MM is the minute offset. For example, Eastern Daylight Time is --0400. - - -\subsection{Identifiers and Namespaces} -\label{sec:format.id} - -This section describes the various naming convention for -objects such as channels, users, and services within a haver server. - -\subsubsection{Identifiers} - -Identifiers may begin with an optional ampersand or dollar sign, -and must then be followed (or start with in the first place) a lower-case letter, -and then must be followed by at least one lower case letter, number, -underscore, single quote, hyphen or at symbol. - -All identifiers that begin with either an ampersand or dollar sign, -or that contain the at symbol, are reserved for the server and for services -with appropriate authority. - - -\verb!/[&$]?[a-z][a-z0-9_'@-]+/! - -A user client will not be allowed to login with user ids that fail to match \verb!/[a-z][a-z0-9_'-]+/!, -nor create channel ids fail to match the same. - -\subsubsection{Namespaces} - -Namespaces are used to separate the identifiers for different types of things, -so that, for example, there may be a channel named joe and a user named joe. -Namespaces are composed of only lower case letters. - - -\verb!/[a-z]+/! Copied: trunk/docs/manual/config.m4 (from rev 341, branches/protocol-v4/docs/manual/config.m4) Copied: trunk/docs/manual/haver.bib (from rev 341, branches/protocol-v4/docs/manual/haver.bib) Modified: trunk/docs/manual/haver.tex =================================================================== --- trunk/docs/manual/haver.tex 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/docs/manual/haver.tex 2004-08-08 22:46:47 UTC (rev 342) @@ -1,10 +1,19 @@ % Date: Wednesday, May 26 at 7:45PM \documentclass[12pt]{report} +\usepackage{ifthen} + +\input{config} +\input{macros} + +\ifhas{COLOR}{\usepackage{color}} \usepackage{url} -\input{macros} +\ifhas{PDF}{\usepackage[pdftex]{hyperref}} + +\input{style} + + \title{The Divine Secrets of Haver} \author{Dylan William Hardison} - \date{\today} \begin{document} @@ -29,7 +38,8 @@ \include{chap/introduction} \include{chap/protocol} -\include{chap/concepts} +\include{chap/formats} +\include{chap/commands} \bibliographystyle{plain} \bibliography{haver} Modified: trunk/docs/manual/macros.tex =================================================================== --- trunk/docs/manual/macros.tex 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/docs/manual/macros.tex 2004-08-08 22:46:47 UTC (rev 342) @@ -1,4 +1,7 @@ -\newcommand{\function}[1]{#1()} -\newcommand{\comment}[1]{(\emph{#1})} - +\newcommand{\ifhas}[2]{% +\ifthenelse{\boolean{have#1}}{#2}{ }% +} +\newcommand{\ifhaselse}[3]{% +\ifthenelse{\boolean{have#1}}{#2}{#3}% +} Copied: trunk/docs/manual/style.tex (from rev 341, branches/protocol-v4/docs/manual/style.tex) Copied: trunk/docs/protocol/formats.txt (from rev 341, branches/protocol-v4/docs/protocol/formats.txt) Property changes on: trunk/docs/protocol/formats.txt ___________________________________________________________________ Name: svn:eol-style + native Modified: trunk/jarverd/lib/Jarver/Connection.pm =================================================================== --- trunk/jarverd/lib/Jarver/Connection.pm 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/jarverd/lib/Jarver/Connection.pm 2004-08-08 22:46:47 UTC (rev 342) @@ -62,8 +62,6 @@ haver_error cmd_WANT cmd_ACCEPT - cmd_IN - cmd_OF cmd_JOIN cmd_MSG cmd_USERS @@ -72,6 +70,9 @@ cmd_PART cmd_MARK cmd_INFO + cmd_LINFO + cmd_PMSG + cmd_FAIL )], ], heap => { @@ -132,11 +133,11 @@ $heap->{channel} = $1; $heap->{haver}->put(['JOIN', $1]); } elsif (/^Hc$/ or /^Hc\t(.+)$/) { - $heap->{haver}->put(['IN', $1 || $heap->{channel}, 'USERS']); + $heap->{haver}->put(['USERS', $1 || $heap->{channel}]); } elsif (/^Hb$/) { $heap->{haver}->put(['CHANS']); } elsif (/^Ha$/) { - $heap->{haver}->put(['USERS']); + $heap->{haver}->put(['USERS', '*']); } elsif (/^E(.+)$/) { my $msg = $1; my $kind; @@ -145,24 +146,30 @@ } else { $kind = '"'; } - $heap->{haver}->put(['IN', $heap->{channel}, 'MSG', $kind, $msg]); + $heap->{haver}->put(['MSG', $heap->{channel}, $kind, $msg]); } elsif (/^F([^\t]+)\t(.+)$/) { my $to = $1; my $msg = $2; + my $omsg = $msg; my $kind; if ($msg =~ s/^\.me //) { $kind = ':'; } else { $kind = '"'; } - $heap->{haver}->put(['TO', $to, 'MSG', $kind, $msg]); - $heap->{jrc}->put(join("\t", "F$heap->{name}", $to, $msg.'F')); + $heap->{haver}->put(['PMSG', $to, $kind, $msg]); + $heap->{jrc}->put(join("\t", "F$heap->{name}", $to, $omsg.'F')); } elsif (/^\^(.+)\t(.+)$/) { - my ($type, $data) = ($1, $2); + my ($mark, $data) = ($1, $2); if ($data =~ /^Ic$/) { - $heap->{haver}->put(['MARK', $type, 'TO', '*', 'IN', $heap->{channel}, 'INFO']); + $heap->{haver}->put( + [ + 'MARK', $mark, + 'LINFO', $heap->{channel}, '*' + ] + ); } elsif ($data =~ /^Ia\t?(.+)$/) { - $heap->{haver}->put(['MARK', $type, 'TO', $1, 'IN', $heap->{channel}, 'INFO']); + $heap->{haver}->put(['MARK', $mark, 'INFO', 'user', $1]); } else { $kernel->post('Logger', 'error', "Unknown whois: $data"); } @@ -186,7 +193,8 @@ "Socket generated $operation error ${errnum}: $errstr"); $heap->{jrc} = undef; - $kernel->yield('cleanup', 'DISCON'); + $kernel->yield('shutdown', 'DISCON'); + eval { $heap->{haver}->put(['BYE']) }; } @@ -227,7 +235,7 @@ # Connecting Internet domain socket. my $wheel = POE::Wheel::SocketFactory->new( RemoteAddress => "localhost", # Sets the connect() addre - RemotePort => "7071", # Sets the connect() port + RemotePort => "7070", # Sets the connect() port SuccessEvent => 'haver_connect', # Event to emit on connection FailureEvent => 'haver_fail', # Event to emit on error ); @@ -258,6 +266,7 @@ ErrorEvent => 'haver_error', ); + $wheel->put(['HAVER', $heap->{version}]); $heap->{haver} = $wheel; } @@ -283,52 +292,29 @@ my ($kernel, $heap, $operation, $errnum, $errstr) = @_[KERNEL, HEAP, ARG0..ARG3]; $kernel->post('Logger', 'error', - "Socket generated $operation error ${errnum}: $errstr"); + "Haver socket generated $operation error ${errnum}: $errstr"); $heap->{haver} = undef; - $kernel->yield('cleanup', 'DISCON'); + $kernel->yield('shutdown', 'DISCON'); + eval { $heap->{jrc}->put('wCLost haver connectionw') }; } -sub cmd_IN { - my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0]; - my ($in, $event, @rest) = @$args; - my $cmd = "cmd_$event"; - - - print "Calling $cmd...\n"; - $heap->{in} = $in; - $kernel->call($_[SESSION], $cmd, [EMAIL PROTECTED]); - $heap->{in} = undef; -} - sub cmd_MARK { my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0]; my ($mark, $event, @rest) = @$args; my $cmd = "cmd_$event"; - print "Calling $cmd...\n"; $heap->{mark} = $mark; $kernel->call($_[SESSION], $cmd, [EMAIL PROTECTED]); $heap->{mark} = undef; } -sub cmd_OF { - my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0]; - my ($of, $event, @rest) = @$args; - my $cmd = "cmd_$event"; - - - print "Calling $cmd...\n"; - $heap->{of} = $of; - $kernel->call($_[SESSION], $cmd, [EMAIL PROTECTED]); - $heap->{of} = undef; -} - sub cmd_JOIN { my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0]; + my ($cid, $uid) = @$args; - eval { $heap->{jrc}->put('D'.$heap->{of}."\t".$heap->{in}.'D') }; + eval { $heap->{jrc}->put('D'.$uid."\t".$cid.'D') }; } sub cmd_WANT { @@ -336,7 +322,7 @@ my $want = shift @$args; if ($want eq 'IDENT') { - $heap->{haver}->put(['IDENT', $heap->{name}, 'user', "Jarver + $heap->{version}"]); + $heap->{haver}->put(['IDENT', $heap->{name}]); } else { $heap->{haver}->put(['CANT', $want]); } @@ -351,7 +337,7 @@ sub cmd_MSG { my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0]; - my ($type, $msg) = @$args; + my ($cid, $uid, $type, $msg) = @$args; if ($type eq ':') { $msg = ".me $msg"; @@ -361,18 +347,30 @@ return; } - if ($heap->{in}) { - $heap->{jrc}->put('E'.$heap->{of}."\t".$msg.'E'); - } else { - $heap->{jrc}->put('F'.$heap->{of}."\t".$msg.'F'); + $heap->{jrc}->put('E'.$uid."\t".$msg.'E'); +} + +sub cmd_PMSG { + my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0]; + my ($uid, $type, $msg) = @$args; + + if ($type eq ':') { + $msg = ".me $msg"; } + + if ($type ne '"' && $type ne ':') { + return; + } + + $heap->{jrc}->put('F'.$uid."\t".$msg.'F'); } sub cmd_USERS { my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0]; + my $cid = shift @$args; - if ($heap->{in}) { - $heap->{jrc}->put('H'.$heap->{name}."\tc$heap->{in}\t" . join("\t", @$args) . 'H'); + if ($cid ne '*') { + $heap->{jrc}->put('H'.$heap->{name}."\tc$cid\t" . join("\t", @$args) . 'H'); } else { $heap->{jrc}->put('H'.$heap->{name}."\ta".join("\t", @$args) . 'H'); } @@ -385,17 +383,20 @@ sub cmd_QUIT { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; - $heap->{jrc}->put('C'.$heap->{of}."\t".$heap->{channel}.'C'); + my $uid = shift @$args; + $heap->{jrc}->put('C'.$uid."\t".$heap->{channel}.'C'); } sub cmd_PART { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; - $heap->{jrc}->put('C'.$heap->{of}."\t".$heap->{in}.'C'); + my ($cid, $uid) = $args; + $heap->{jrc}->put('C'.$uid."\t".$cid.'C'); } sub cmd_INFO { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; - my $msg = "^$heap->{name}\t$heap->{mark}\tIa$heap->{of}\t"; + my ($type, $id) = splice(@$args, 0, 2); + my $msg = "^$heap->{name}\t$heap->{mark}\tIa$id\t"; my %hash = @$args; $hash{Access} = delete($hash{Role}) . "\t" . delete($hash{Rank}); @@ -407,6 +408,46 @@ $heap->{jrc}->put($msg); } +sub cmd_LINFO { + my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; + my ($cid, $uid) = splice(@$args, 0, 2); + my $msg = "^$heap->{name}\t$heap->{mark}\tIa$uid\t"; + my %hash = @$args; + $hash{Access} = delete($hash{Role}) . "\t" . delete($hash{Rank}); + + foreach my $key (keys %hash) { + $msg .= "$key\cB$hash{$key}\cC"; + } + $msg .= "\cD^"; + $heap->{jrc}->put($msg); +} + +sub cmd_FAIL { + my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; + my ($cmd, $err, @args) = @$args; + + if ($cmd eq 'IDENT') { + if ($err eq 'used' or $err eq 'reserved') { + $heap->{jrc}->put("xAName in usex"); + } elsif ($err eq 'syntax') { + $heap->{jrc}->put("xASyntax errorx"); + } + $heap->{jrc}->put('wCw'); + $heap->{haver}->put(['BYE']); + $kernel->yield('shutdown'); + } elsif ($cmd eq 'PMSG') { + if ($err eq 'notfound.uid' or $err eq 'syntax.uid') { + $heap->{jrc}->put("xya$args[0]x"); + } + } elsif ($cmd eq 'JOIN') { + if ($err eq 'notfound.cid') { + $heap->{jrc}->put("xyb$args[0]x"); + } elsif ($err eq 'syntax.cid') { + $heap->{jrc}->put("xzb$args[0]x"); + } + } +} + 1; Modified: trunk/main/client/lib/Haver/Client/POE.pm =================================================================== --- trunk/main/client/lib/Haver/Client/POE.pm 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/main/client/lib/Haver/Client/POE.pm 2004-08-08 22:46:47 UTC (rev 342) @@ -17,6 +17,38 @@ # along with this module; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# object fields: +# self => { +# [persistent data] +# options => { key => value }, +# handlers => { +# type => { +# event name => { +# reverse => { +# stringified $subref => index +# }, +# forward => [ +# $subref, +# ... +# ] +# } # event name => +# } # type => +# }, # handlers => +# connection => { +# [connection data] +# UID => $uid, +# authmethods => [ acceptable auth methods ], +# state => STATE_NAME, +# want => 'CURRENTLY_WANTED', +# pending => [ +# ['WAITING', 'FOR', 'WANT'], +# ], +# POE => { +# connwheel => POE::Wheel::ConnectionFactory, +# sockwheel => POE::Wheel::ReadWrite +# }, +# } # connection => +# } =head1 NAME @@ -26,8 +58,9 @@ use Haver::Client::POE; - new Haver::Client::POE('haver'); - POE::Kernel->post('haver', 'connect', Host => 'example.com', + my $conn = new Haver::Client::POE('haver'); + $conn->register(connected => \&on_connect); + $conn->connect( Host => 'example.com', Port => 7070, UID => 'example'); @@ -45,16 +78,24 @@ use strict; use warnings; +use constant { + TRUE => 1, + FALSE => 0, + STATE_IDLE => 0, # not connected or connecting + STATE_CONNECT => 1, # establishing connection + STATE_AUTH => 2, # authenticating + STATE_READY => 3, # ready for user control + STATE_DISCON => 4, # disconnecting +}; + +use Carp; + use POE qw(Wheel::ReadWrite Wheel::SocketFactory); -use Haver::Preprocessor; -use Haver::Util::Misc qw(format_datetime); + use POE::Filter::Haver; +use Haver::Preprocessor; use Haver::Formats::Error; -use Carp; -use Digest::SHA1 qw(sha1_base64); -use Data::Dumper; -use base 'POE::Session::EventSource'; our $VERSION = 0.06; @@ -76,93 +117,91 @@ sub _object_states { my ($self, $ehash) = @_; - $ehash = {(map {$_ => $_} qw{ - _start - setoptions + $ehash = {qw{ + _start _start + _default _default + }, %$ehash}; + return $self->SUPER::_object_states($ehash); +} - dispatch - dispatch_ref +### SETUP - connect - connected - connectfail +=head2 new([option => value ...]) - net_in - input - send_raw - send - _flush_msgq - net_error +Creates a new Haver::Client::POE session, and optionally sets one or more +options (see C<setoptions>) - destroy - disconnect - force_close - flushed - cleanup +=cut - login - join - part - msg - pmsg - users - make - chans +sub new { + my ($class, %options) = @_; + $class = ref $class || $class; - event_WANT - event_ACCEPT - event_REJECT - event_PING - event_CLOSE - event_IN - event_OF - - event_JOIN - event_PART - event_MSG - event_USERS - event_BYE - event_QUIT - event_CHANS - event_WARN - event_DIE + my $self = { + options => { + version => "Haver::Client::POE/$VERSION", + }, + handlers => { + }, + }; + bless $self, $class; + $self->_init_wants; + $self->_init_msgs; +} - _default - }), %$ehash}; - return $self->SUPER::_object_states($ehash); +sub _start { + die "STUB"; } -### SETUP +# Internal: _init_event_type($type) +# Prepares to register events of type $type -=head2 new($Z<>alias [, option => value ...]) +sub _init_event_type { + my $self = shift; + $self->{handlers}{shift} = { + hhash => {}, + byname => {}, + } +} -Creates a new Haver::Client::POE session with alias $alias, and optionally -sets one or more options (see C<setoptions>) +# Internal: _init_wants +# Sets up default handlers for wants -=cut - -sub new { - my ($class, $alias, %options) = @_; - my $self = $class->SUPER::new(prefix => delete($options{prefix}) || 'haver_', args => [$alias, %options]); - return 1; +sub _init_wants { + my $self = shift; + my %wants = { + # TODO ... + }; + $self->_init_event_type('wants'); + for (my ($event, $handler) = each %wants) { + $self->register_handler($self, 'want', $event, $handler); + } + $self->register_handler($self, 'want', '_default', + sub { + my ($handled, $type, $evname, $args) = @_; + my $name = $args->[0]; + $self->send_raw('CANT', $name); + $handled = 1; + } + ); } -sub _start { - my ($kernel, $self, $session, $alias, @args) = @_[KERNEL,OBJECT,SESSION,ARG0..$#_]; - $_[HEAP]->{object} = $self; - $self->{alias} = $alias; - $kernel->alias_set($self->{alias}); - $self->{scope} = undef; - $self->{debug} = 0; - $self->{autorespond} = { 'PING?' => 1, 'TIME?' => 1 }; - $self->{version} = "Haver::Client::POE/$VERSION"; - if (@args) { - _call('setoptions', @args); +# Internal: _init_smsg +# Sets up default handlers for server messages + +sub _init_smsg { + my $self = shift; + my %smsgs = { + # TODO ... + }; + $self->_init_event_type('smsg'); + for (my ($event, $handler) = each %smsgs) { + $self->register_handler($self, 'smsg', $event, $handler); } } -=head1 MESSAGES + =head2 setoptions(option => value [, ...]) Sets one or more options to the given value. The following options are available: @@ -182,78 +221,20 @@ =cut sub setoptions { - my ($kernel, $self, %args) = @_[KERNEL,OBJECT,ARG0..$#_]; - my %setters = ( - debug => sub { $self->{debug} = $_[0]; }, - autorespond => sub { $self->{autorespond} = map { ($_ => 1) } @_ }, - version => sub { $self->{version} = $_[0]; }, - ); - for (keys %args) { - $setters{$_}->($args{$_}) if exists $setters{$_}; - } + die "STUB"; } -### DISPATCH - -=head2 register($Z<>event1 [,...]) - -Registers to receive the events listed. When a matching event is dispatched, it will be sent to -the calling session as 'haver_eventname'. The special event name 'all' may be specified to register for all -events. A given event will not be sent to any given session more than once. - -=head2 unregister($Z<>event1 [,...]) - -Unregisters from the specified event. Events registered using 'all' must be unregistered using 'all'. - -=cut - -sub dispatch_ref { - my ($kernel, $self, $event, $args) = @_[KERNEL,OBJECT,ARG0,ARG1]; - $kernel->yield('_dispatch', $event, $args, $self->{IN}, $self->{OF}); -} - -sub dispatch { - my @pre = @_[0..ARG0]; - my $payload = [EMAIL PROTECTED]; - @_ = (@pre, $payload); - goto &dispatch_ref; -} - ### SESSION MANAGEMENT -=head2 B<connect(Host => $Z<>host, [Port => $Z<>port, UID => $Z<>uid, Password => $Z<>password]) +=head2 connect(Host => $Z<>host, [Port => $Z<>port]) Connects to the haver server. The Host option is mandatory, all others are optional. If it is already connected, it will disconnect, then connect with the new parameters. -Password is deprecated, and will be removed some time after SSL is supported. - =cut sub connect { - my ($kernel, $self, %args) = @_[KERNEL,OBJECT,ARG0..$#_]; -# XXX: Better error reporting - croak "Missing required parameter Host" unless exists $args{Host}; - if (exists $self->{conn}) { - $kernel->yield('disconnect') unless exists $self->{pending_connection}; - $self->{pending_connection} = [%args]; - return; - } - $self->{UID} = $args{UID}; - $self->{PASS} = $args{Password}; - $self->{Host} = $args{Host}; - undef $self->{want}; - $self->{enabled} = 1; # Set to 0 when graceful shutdown begins, to block user input - $self->{accepted} = 0; # Set to 1 when login is successful - $self->{dead} = 0; # Set to 1 when the socket fails, to drop messages - $args{Port} ||= 7070; - $self->{connect_wheel} = - POE::Wheel::SocketFactory->new( - RemoteAddress => $args{Host}, - RemotePort => $args{Port}, - SuccessEvent => 'connected', - FailureEvent => 'connectfail' - ); + die "STUB"; } =head2 disconnect(Z<>) @@ -264,68 +245,9 @@ =cut sub disconnect { - my ($kernel, $self) = @_[KERNEL, OBJECT]; - $self->{enabled} = 0; - return if $self->{closing}; - $self->{closing} = 1; - if ($self->{want}) { - $kernel->yield('cleanup'); - } else { - $kernel->yield('send', 'QUIT'); - $kernel->delay('force_close', 5); - } + die "STUB"; } -sub connected { - my ($kernel, $self) = @_[KERNEL, OBJECT]; - my ($handle, $id) = @_[ARG0,ARG3]; - if (!exists $self->{connect_wheel} || - $self->{connect_wheel}->ID() != $id){ - close $handle; - return; - } - binmode $handle, ':utf8'; - $self->{conn} = - POE::Wheel::ReadWrite->new( - Handle => $handle, - Driver => POE::Driver::SysRW->new(), - Filter => POE::Filter::Haver->new(), - InputEvent => 'net_in', - FlushedEvent => 'flushed', - ErrorEvent => 'net_error' - ); - delete $self->{connect_wheel}; - $self->{flushed} = 1; - _call('dispatch', 'connected'); -} - -sub connectfail { - my ($kernel, $self, $enum, $estr) = @_[KERNEL,OBJECT,ARG1,ARG2]; - _call('dispatch', 'connect_fail', $enum, $estr); - delete $self->{connect_wheel}; -} - -sub net_error { - my ($kernel, $self, $enum, $estr) = @_[KERNEL,OBJECT,ARG1,ARG2]; - _call('dispatch', 'disconnected', $enum, $estr); - $kernel->yield('cleanup'); -} - -### IO - -sub net_in { - my ($kernel, $self, $event) = @_[KERNEL,OBJECT,ARG0]; - _dprint 1, "S: ", join("\t", @$event), "\n"; - _call('dispatch', 'raw_in', @$event); - goto &input; -} - -sub input { - my ($kernel, $self, $event) = @_[KERNEL,OBJECT,ARG0]; - my $ename = shift @$event; - _call("event_$ename", @$event); -} - =head2 send_raw(@args) Sends the arguments specified to the haver server. No checking is performed, though escaping may occur. @@ -333,261 +255,43 @@ =cut sub send_raw { - my ($kernel, $self, @message) = @_[KERNEL,OBJECT,ARG0..$#_]; - return if ($self->{dead}); - eval { $self->{conn}->put([EMAIL PROTECTED]); }; - if ($@) { - # Ack, lost connection unexpectedly! - # Hopefully we get net_error soon - $self->{dead} = 1; - return; - } - _dprint 1, "C: ", join("\t", map { defined($_) ? $_ : '~UNDEF~' } @message), "\n"; - _call('dispatch', 'raw_out', @message); - $self->{flushed} = 0; + die "STUB"; } -sub send { - my ($kernel, $self, @message) = @_[KERNEL,OBJECT,ARG0..$#_]; - my $block = 0; - - if (!$self->{enabled}) { - $block = 1; - } elsif ($self->{accepted} && !$self->{want}) { - $block = 0; - } elsif (!$self->{want}) { - # Before we get a S: ACCEPT we can't send anything not in response to a S: WANT - $block = 1; - } elsif ($message[0] eq 'CANT') { - $block = ($message[1] ne $self->{want}); - } elsif ($message[0] ne $self->{want}) { - $block = 1; - } - - if ($block) { - _dprint 1, "(blocked) C: ", join("\t", @message), "\n"; - push @{$self->{messageq} ||= []}, [EMAIL PROTECTED]; - return; - } - - delete $self->{want}; - - $kernel->yield('send_raw', @message); - - $kernel->yield('_flush_msgq'); -} +=head2 send(@args) -sub _flush_msgq { - my ($kernel, $self) = @_[KERNEL,OBJECT]; - if (exists $self->{messageq}) { - for (@{$self->{messageq}}) { - $kernel->yield('send', @$_); - } - delete $self->{messageq}; - } -} +Sends the arguments specified to the Haver server. If authentication is not +yet completed, it will be queued until authentication is completed. -### SERVER EVENTS +=cut -# XXX: Make a more extensible WANT system later -# -# hmm, I reformatted this a bit so it is possible -# to easily edit in vim. :P (dylan) -sub event_WANT { - my ($kernel, $self, $wanted, @arg) = @_[KERNEL,OBJECT,ARG0,ARG1]; - $wanted = uc $wanted; - $self->{want} = $wanted; - my %wants = ( - IDENT => sub { - $kernel->yield('send', 'IDENT', $self->{UID}, 'user', $self->{version}); - }, - AUTH => sub { - # XXX: More extensible AUTH system later too - my @methods = split ',', $arg[0]; - # XXX: only pass for now - unless(grep { $_ eq 'pass' } @methods) { - $kernel->yield('send', 'CANT', 'AUTH'); - return; - } - $kernel->yield('send', 'AUTH', 'pass'); - $self->{auth} = 'pass'; - }, - 'AUTH:PASS' => sub { - # XXX: Better support for namespaces - if($self->{PASS}) { - $kernel->yield('login', $self->{PASS}); - return; - } - $kernel->yield('dispatch', 'login_request'); - }, - ); - if (exists $wants{$wanted}) { - $wants{$wanted}->(); - } else { - $kernel->yield('send', 'CANT', $wanted); - } +sub send { + die "STUB" } -sub event_ACCEPT { - my ($kernel, $self) = @_[KERNEL,OBJECT]; - $self->{logged_in} = 1; - $self->{accepted} = 1; - _call('dispatch', 'login'); - $kernel->yield('_flush_msgq'); -} +### CLIENT EVENTS -sub event_REJECT { - my ($kernel, $self, $uid, $err) = @_[KERNEL,OBJECT,ARG0,ARG1]; - my $e = new Haver::Formats::Error; - _call('dispatch', 'login_fail', - $err, - $e->get_short_desc($err), - $e->format( $e->get_long_desc($err), $uid ) - ); - delete $self->{UID}; - delete $self->{PASS}; - $self->{want} = 'UID'; -} +=head2 login(UID => $Z<>uid) -sub event_PING { - my ($kernel, $self, @junk) = @_[KERNEL,OBJECT,ARG0..$#_]; - $kernel->yield('send', 'PONG', @junk); -} +Specifies the UID to use to log in. If authentication is already complete, +this has no effect. -sub event_CLOSE { - my ($kernel, $self, $etyp, $estr) = @_[KERNEL,OBJECT,ARG0,ARG1]; - _call('dispatch', 'close', $etyp, $estr); -} +=cut -sub event_JOIN { - my ($kernel, $self) = @_[KERNEL,OBJECT,ARG0,ARG1]; - my $event = 'join'; - if (!defined($self->{OF}) || - $self->{OF} eq '.' || - $self->{OF} eq $self->{UID}) { - $event = 'joined'; - } - _call('dispatch', $event); +sub login { + die "STUB"; } -sub event_PART { - my ($kernel, $self) = @_[KERNEL,OBJECT,ARG0,ARG1]; - my $event = 'part'; - if (!defined($self->{OF}) || - $self->{OF} eq '.' || - $self->{OF} eq $self->{UID}) { - $event = 'parted'; - } - _call('dispatch', $event); -} +=head2 authenticate($Z<>method, @Z<>args) -my %autorespond = ( - 'PING?' => sub { - my ($kernel, $self, $who, @junk) = @_[KERNEL,OBJECT,ARG0..$#_]; - if ([EMAIL PROTECTED]) { - @junk = (''); # This silences a warning elsewhere - } - $kernel->yield('pmsg', 'PING', $who, @junk); - }, - 'TIME?' => sub { - my ($kernel, $self, $who) = @_[KERNEL,OBJECT,ARG0]; - $kernel->yield('pmsg', 'TIME', $who, format_datetime(time())); - }, -); +Authenticates to the server. $method must be an object of type +Haver::Client::POE::Auth capable of handling an authentication +type listed in the auth_request() message. -sub event_MSG { - my ($kernel, $self, $type, @text) = @_[KERNEL,OBJECT,ARG0..$#_]; - if ($self->{autorespond}->{$type} && exists $autorespond{$type}) { - $autorespond{$type}->(@_[0..ARG0-1], @text); - return if ($self->{supress_auto}); - } - - if ($self->{IN}) { - _call('dispatch', 'msg', $type, @text); - } else { - _call('dispatch', 'pmsg', $type, @text); - } - -} - -sub event_USERS { - my ($kernel, $self, @who) = @_[KERNEL,OBJECT,ARG0..$#_]; - - _call('dispatch_ref', 'users', [EMAIL PROTECTED]); -} - -sub event_BYE { - my ($kernel, $self, $why) = @_[KERNEL,OBJECT,ARG0]; - _call('dispatch', 'bye', $why); -} - -sub event_QUIT { - my ($kernel, $self, $who, $why) = @_[KERNEL,OBJECT,ARG0,ARG1]; - _call('dispatch', 'quit', $who, $why); -} - -sub event_CHANS { - my ($kernel, $self, @channels) = @_[KERNEL,OBJECT,ARG0..$#_]; - _call('dispatch', 'chans', @channels); -} - -sub event_WARN { - my ($kernel, $err, @args) = @_[KERNEL,ARG0..$#_]; - my $e = new Haver::Formats::Error; - _call('dispatch', 'warn', - $err, - $e->get_short_desc($err), - $e->format( $e->get_long_desc($err), @args ), - @args - ); -} - -sub event_DIE { - my ($kernel, $err, @args) = @_[KERNEL,ARG0..$#_]; - my $e = new Haver::Formats::Error; - _call('dispatch', 'die', - $err, - $e->get_short_desc($err), - $e->format( $e->get_long_desc($err), @args ), - @args - ); -} - -sub event_IN { - my ($kernel, $self, $cid, @cmd) = @_[KERNEL,OBJECT,ARG0..$#_]; - my $save = $self->{IN}; - $self->{IN} = $cid; - _call('input', [EMAIL PROTECTED]); - $self->{IN} = $save; -} - -sub event_OF { - my ($kernel, $self, $uid, @cmd) = @_[KERNEL,OBJECT,ARG0..$#_]; - my $save = $self->{OF}; - $self->{OF} = $uid; - _call('input', [EMAIL PROTECTED]); - $self->{OF} = $save; -} - -### CLIENT EVENTS - -=head2 login($Z<>pass) - -Specify a password to use for the next login. If already logged in, this takes effect on the next connection -unless overridden by connect(). If the server is waiting for a login, takes effect immediately. - =cut -sub login { - my ($kernel, $self, $pass) = @_[KERNEL,OBJECT,ARG0,ARG1]; - $self->{PASS} = $pass if $pass; - if ($self->{want} eq 'AUTH:PASS') { - if (defined $self->{PASS}) { - $kernel->yield('send', 'AUTH:PASS', sha1_base64($self->{UID} . $self->{PASS} . $self->{Host})); - } else { - $kernel->yield('send', 'CANT', 'AUTH:PASS'); - } - } +sub authenticate { + die "STUB"; } =head2 join($Z<>channel) @@ -597,8 +301,7 @@ =cut sub join { - my ($kernel, $self, $where) = @_[KERNEL,OBJECT,ARG0]; - $kernel->yield('send', 'JOIN', $where); + die "STUB"; } =head2 part($Z<>channel) @@ -608,8 +311,7 @@ =cut sub part { - my ($kernel, $self, $where) = @_[KERNEL,OBJECT,ARG0]; - $kernel->yield('send', 'PART', $where); + die "STUB"; } =head2 make($Z<>channel) @@ -619,30 +321,27 @@ =cut sub make { - my ($kernel, $self, $cid) = @_[KERNEL,OBJECT,ARG0]; - $kernel->yield('send', 'MAKE', $cid); + die "STUB"; } -=head2 B<msg($Z<>channel, $Z<>type, $Z<>text)> +=head2 msg($Z<>channel, $Z<>type, $Z<>text) Sends a message with specified type and text to $channel. =cut sub msg { - my ($kernel, $self, $where, $type, $message) = @_[KERNEL,OBJECT,ARG0..ARG2]; - $kernel->yield('send', 'IN', $where, 'MSG', $type, $message); + die "STUB"; } -=head2 B<pmsg($Z<>uid, $Z<>type, $Z<>text)> +=head2 pmsg($Z<>uid, $Z<>type, $Z<>text) Sends a private message with specified type and text to $uid. =cut sub pmsg { - my ($kernel, $self, $where, $type, $message) = @_[KERNEL,OBJECT,ARG0..ARG2]; - $kernel->yield('send', 'TO', $where, 'MSG', $type, $message); + die "STUB"; } =head2 users($Z<>channel) @@ -652,8 +351,7 @@ =cut sub users { - my ($kernel, $self, $where) = @_[KERNEL,OBJECT,ARG0]; - $kernel->yield('send', 'IN', $where, 'USERS'); + die "STUB"; } =head2 chans(Z<>) @@ -663,47 +361,9 @@ =cut sub chans { - my $kernel = $_[KERNEL]; - $kernel->yield('send', 'CHANS'); + die "STUB"; } -### SHUTDOWN - -sub force_close { - my ($kernel, $self) = @_[KERNEL, OBJECT]; - return if $self->{closing} == 3; - if ($self->{closing} == 2 || $self->{flushed}){ # Flushed or flush timeout - $kernel->yield('cleanup'); - _call('dispatch', 'disconnected', -1, 'Disconnected'); - $kernel->delay('force_close'); - $self->{closing} = 3; - return; - } - $self->{closing} = 2; - $kernel->delay('force_close', 5); -} - -sub flushed { - my ($kernel, $self) = @_[KERNEL, OBJECT]; - if (defined $self->{closing} && $self->{closing} == 2) { - $kernel->yield('force_close'); - } - $self->{flushed} = 1; -} - -sub cleanup { - my ($kernel, $self) = @_[KERNEL, OBJECT]; - delete $self->{$_} for qw(conn flushed closing UID PASS want messageq enabled accepted dead); - $kernel->delay('force_close'); - - if ($self->{destroy_pending}) { - $kernel->yield('destroy'); - } elsif (exists $self->{pending_connection}) { - $kernel->yield('connect', @{$self->{pending_connection}}); - delete $self->{pending_connection}; - } -} - =head2 destroy(Z<>) Disconnects from the Haver server, and destroys the session. This event may not complete @@ -713,14 +373,7 @@ =cut sub destroy { - my ($kernel, $self) = @_[KERNEL, OBJECT]; - _dprint 1, "Destroying.\n"; - if (exists $self->{conn}){ - $self->{destroy_pending} = 1; - $kernel->yield('disconnect'); - return; - } - $kernel->alias_remove($self->{alias}); + die "STUB"; } sub _default { @@ -730,111 +383,239 @@ return 0; } +=head1 HANDLERS +Handlers are subroutines called to handle some event from the server. Any +number of handlers may be registered to an event, and they will be called +in reverse order of registration until one indicates that it has handled the +event. + +The handler prototype is as follows: + + sub handler { + my ($handled, $type, $name, $args) = @_; + # ... + $handled = 1; # To handle the event + } + +$type is the type of event, $name is the event name, and $args is an array ref +of arguments for the event. + +If $handled is 0 when the handler returns, the next handler in the chain will +be called. Any changes to the contents of $args will be passed on. + +If no handler in a chain handles the event, an event with the same type and +a name of '_default' will be generated, with the old event name prepended +to @args. If no handler in the _default chain handles the event, it will be +discarded. + +=head2 METHODS FOR EVENT MANIPULATION + +=head3 register_handler($Z<>type, $Z<>event, $Z<>handler) + +Register a handler $handler for an event of type $type, name $event. If such +a handler already exists, does nothing. + +=cut + +sub register_handler { + my ($self, $type, $event, $handler) = @_; + my $htype = $self->{handlers}{$type} + or croak "Unknown event type $type"; + my $hevent = $htype->{$event}; + if (!$hevent) { + $hevent = $htype->{$event} = { + forward => {}, + reverse => {}, + }; + } + return if (exists $hevent->{reverse}{$handler}); + my $index = @{$hevent->{forward}}; + push @{$hevent->{forward}}, $handler; + $hevent->{reverse}{$handler} = $index; +} + +=head3 unregister_handler($Z<>type, $Z<>event, $Z<>handler) + +Unregisters a handler previously registered by passing the same arguments +to register_handler. If such a handler does not exist, does nothing. + +=cut + +sub unregister_handler { + my ($self, $type, $event, $handler) = @_; + my $htype = $self->{handlers}{$type} + or croak "Unknown event type $type"; + my $hevent = $self->{handlers}{$type}{$event} or return; + my $index = $hevent->{reverse}{$handler} or return; + # Remove the item + splice @{$hevent->{forward}}, $index, 1; + # and renumber the ones afterward + my $len = @{$hevent->{forward}}; + for (; $index < $len; $index++) { + my $handler = $hevent->{forward}[$index]; + $hevent->{reverse}{$handler} = $index; + } + # and delete the reverse mapping + delete $hevent->{reverse}{$handler}; +} + +# Internal: _event_dispatch($type, $event, @args) +# dispatches event $event + +sub _event_dispatch { + my ($self, $type, $event, @args) = @_; + my $etype = $self->{handlers}{$type} + or croak "Unknown event type $etype"; + my $ev = $etype->{$event}; + if (!$ev) { + if ($event eq '_default') { + return; # Nobody seems to be interested. + } + $self->_event_dispatch($type, '_default', $event, @args); + } + for my $handler (@{$ev->{forward}}) { + my $handled = 0; + $handler->($handled, $type, $event, [EMAIL PROTECTED]); + return if $handled; + } + if ($event ne '_default') { + $self->_event_dispatch($type, '_default', $event, @args); + } +} + + + 1; __END__ -=head1 EVENTS +=head2 TYPES OF EVENTS -Event callbacks are called with the frist argument being the event arguments, -the second argument being the channel set by IN (or undef if not set), and the -thirs argument being the UID set by OF. Example: +=head3 want - sub haver_connect_fail { - my ($args, $cid, $uid) = @_[ARG0..ARG2]; - my ($enum, $estr) = @$args; +Events of type 'want' are sent when the server sends a S: WANT message. The +first argument of the S: WANT is the event name, the rest are used as +arguments for the first handler. + +The default action, should all handlers pass the event, is to send a +C: CANT $event to the server. + +=head3 smsg + +Events of type 'smsg' are sent whenever a command is received from the server. +The command name is used for the event name, and the arguments are passed for +the first handler's @args. + +Note that adding a handler with $type of smsg, and $event of 'WANT' may +prevent handlers of $type want from being called. + +=head3 client + +Client events have the following prototype: + + sub handler { + my ($handled, $type, $event, $_args) = @_; + my ($context, @evargs) = @$_args; # ... } -=head2 haver_connected(Z<>) +$context is a hash reference with the following arguments: +* IN - Indicates the channel set by S: IN +* ON - Indicated the UID set by S: ON +The contents of @evargs vary depending on the event name, and are documented +below. + +=head4 connected(Z<>) + This event is sent when a connection is established (but before it is logged in) -=head2 haver_connect_fail($Z<>enum, $Z<>estr) +=head4 connect_fail($Z<>enum, $Z<>estr) The connection could not be established. An error code is in $enum, and the human-readable version is in $estr -=head2 haver_disconnected($Z<>enum, $Z<>estr) +=head4 disconnected($Z<>enum, $Z<>estr) The connection has been lost. If the server closed the connection, $enum will be 0 and $estr will be meaningless. If the user closed the connection, and the server failed to respond, $enum will be -1. Otherwise, $enum will contain an error code, and $estr the human-readable version. -=head2 haver_raw_in(@data) +=head4 raw_in(@data) The client has received @data from the Haver server. Mostly useful for debugging. -=head2 haver_raw_out(@data) +=head4 raw_out(@data) The client has sent @data to the Haver server. Mostly useful for debugging. -=head2 haver_login_request(Z<>) +=head4 login_request(Z<>) -The server is asking for a login, and one was not provided in connect(). The connection will not proceed until -login() is sent with the password. +The server is asking for a UID, and one was not provided in connect(). +The authentication will not proceed until login() is invoked with the UID. -=head2 haver_login(Z<>) +=head4 auth_request(@Z<>methods) -The client has successfully logged in. +The server requests authentication using one of the listed methods. The +authentication will not proceed until authenticate() is invoked with a +suitable authentication handler. -=head2 haver_login_fail($Z<>error, $Z<>error_short, $Z<>error_long, $Z<>uid) +=head4 login(Z<>) -Login with UID $uid has failed with error $error. Human-readable short and long versions, respectively, are -in $error_short and $error_long. +The client has successfully logged in. -=head2 haver_close($Z<>etyp, $Z<>estr) +=head4 close($Z<>etyp, $Z<>estr) Z<XXX: Describe args> Server is closing connection, and sent $etyp and $estr -=head2 haver_join(Z<>) +=head4 join(Z<>) $uid has joined $cid -=head2 haver_joined(Z<>) +=head4 joined(Z<>) The client has joined $cid. -=head2 haver_part(Z<>) +=head4 part(Z<>) $uid has left $cid. -=head2 haver_parted(Z<>) +=head4 parted(Z<>) The client has left $Z<>cid. -=head2 haver_msg($Z<>type, @Z<>msg) +=head4 msg($Z<>type, @Z<>msg) A public message with type $type and contents @msg was sent on channel $cid by user $uid. -=head2 haver_pmsg($Z<>type, @Z<>text) +=head4 pmsg($Z<>type, @Z<>text) A private message with type $type and contents @msg was sent to you by user $uid. -=head2 haver_users(@Z<>who) +=head4 users(@Z<>who) Channel $cid has the users listed in @who in it. Sent in response to message users(). -=head2 haver_bye($Z<>why) +=head4 bye($Z<>why) The server is disconnecting you due to the reason in $why -=head2 haver_chans(@Z<>channels) +=head4 chans(@Z<>channels) The server has the channels listed in @channels. Sent in response to message chans() -=head2 haver_warn($Z<>err, $Z<>short, $Z<>long, @Z<>args) +=head4 warn($Z<>err, $Z<>short, $Z<>long, @Z<>args) The server has sent a non-fatal error message with code $err and arguments @args. $short and $long have the short and long human-readable forms, respectively. -=head2 haver_die($Z<>err, $Z<>short, $Z<>long, @Z<>args) +=head4 die($Z<>err, $Z<>short, $Z<>long, @Z<>args) The server has sent a fatal error message with code $err and arguments @args. $short and $long have the short and long human-readable forms, respectively. The connection will be closed shortly. -=head2 haver_quit($Z<>why) +=head4 quit($Z<>why) UID $uid has disconnected due to the reason in $why. Modified: trunk/main/server/lib/Haver/Server/Object.pm =================================================================== --- trunk/main/server/lib/Haver/Server/Object.pm 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/main/server/lib/Haver/Server/Object.pm 2004-08-08 22:46:47 UTC (rev 342) @@ -85,6 +85,7 @@ $me->SUPER::initialize(); $me->{_fields} = {}; + $me->{_loc} = {}; $me->{id} ||= $ID++; my @ns = @{ (delete $me->{namespaces}) || [] }; @@ -135,6 +136,14 @@ } } +sub lset { + my ($me, $loc, @set) = @_; + + while (my ($k,$v) = splice(@set, 0, 2)) { + $me->{_loc}{$loc}{$k} = $v; + } +} + sub get { my ($me, @keys) = @_; @@ -150,6 +159,20 @@ return wantarray ? @values : [EMAIL PROTECTED] ; } +sub lget { + my ($me, $loc, @keys) = @_; + + if (@keys <= 1) { + return _val($me->{_loc}{$loc}{$keys[0]}, $me); + } + my @values; + + foreach my $key (@keys) { + push(@values, _val($me->{_loc}{$loc}{$key}, $me)); + } + + return wantarray ? @values : [EMAIL PROTECTED] ; +} sub _val { return $_[0] if not ref $_[0]; @@ -263,7 +286,6 @@ - sub has_namespace { my ($me, $ns) = @_; return exists $me->{".$ns"}; @@ -273,7 +295,11 @@ my ($this, $uid) = @_; if (defined $uid && $uid =~ /^$IdPattern$/) { - return 1; + if (length($uid) > 2 and length($uid) < 20) { + return 1; + } else { + return 0; + } } else { return 0; } @@ -344,7 +370,13 @@ wantarray ? @v : [EMAIL PROTECTED]; } + sub list_vals { + carp "->list_vals is deprecated!"; + shift->contents(@_); +} + +sub contents { my ($me, $ns) = @_; my $h = $me->{".$ns"}; Modified: trunk/main/server/lib/Haver/Server/POE/Commands.pm =================================================================== --- trunk/main/server/lib/Haver/Server/POE/Commands.pm 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/main/server/lib/Haver/Server/POE/Commands.pm 2004-08-08 22:46:47 UTC (rev 342) @@ -36,12 +36,16 @@ our @Commands = qw( IDENT CANT - PONG AUTH AUTH:PASS - IN TO - MSG JOIN PART QUIT - USERS CHANS INFO MARK + MSG PMSG + JOIN PART BYE + HAVER + INFO + LINFO + MARK + USERS + CHANS ); @@ -58,68 +62,86 @@ # $cmds{cmd_REVOKE} = 'cmd_GRANTCMD'; # $cmds{cmd_CLEAR} = 'cmd_GRANTCMD'; - $cmds{unknown_cmd} = 'do_unknown_cmd'; return \%cmds; } -sub do_unknown_cmd { - my ($kernel, $heap, $event, $args) = @_[KERNEL, HEAP, ARG0, ARG1]; +#> [HAVER] +#> C: HAVER $client +#> S: HAVER $server +sub cmd_HAVER { + my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; + my $client = $args->[0]; - $kernel->yield('warn', 'unknown.cmd' => [$event], $heap->{scope}{cid}); + $heap->{socket}->put(['HAVER', "Haver::Server::POE/$Haver::Server::POE::VERSION"]); + $heap->{client} = $client; + $kernel->yield('want', 'IDENT'); } -#> IDENT($uid, $type) +#> [IDENT] +#> C: IDENT $id [$ns] +#> S: ACCEPT $id +#> | WANT AUTH ... +#> Errors: +#> * ns-unknown -- %1 is an unknown type (namespace) of client. +#> * syntax -- %1 this is an illegal id. +#> * reserved -- %1 is reserved for something else. +#> * used -- %1 is already being used. sub cmd_IDENT { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; - my ($uid, $type, $client) = @$args; + my ($id, $ns) = @$args; + $ns ||= 'user'; return if $heap->{login}; - if ($type ne 'user') { - $kernel->yield('die', 'unknown.type', [$type]); + if ($ns ne 'user') { + $kernel->yield('die', 'ns-unknown', [$ns]); return; } - unless (Haver::Server::Object::User->is_valid_id($uid)) { - $poe_kernel->yield('die', 'syntax.id.user', [$uid]); - } elsif ($type eq 'user' and ($uid =~ /&/ or $uid =~ /@/)) { - $poe_kernel->yield('die', 'reserved.id.user', [$uid]); + unless (Haver::Server::Object::User->is_valid_id($id)) { + $kernel->yield('fail', 'IDENT', 'syntax', [$id]); + $kernel->yield('want', 'IDENT'); + } elsif ($ns eq 'user' and ($id =~ /&/ or $id =~ /@/)) { + $poe_kernel->yield('fail', 'IDENT', 'reserved', [$id]); + $kernel->yield('want', 'IDENT'); } else { - if ($Registry->contains('user', $uid)) { - $poe_kernel->yield('die', 'exists.user', [$uid]); + if ($Registry->contains('user', $id)) { + $poe_kernel->yield('fail', 'IDENT', 'used', [$id]); + $kernel->yield('want', 'IDENT'); } else { my $user = new Haver::Server::Object::User( - id => $uid, + id => $id, wheel => $heap->{socket}, sid => $_[SESSION]->ID, ); $user->set( - ClientType => $type, - Client => $client, + Client => $heap->{client}, Rank => 0, Role => 'User', + _info => [qw( Rank Role Client IP Login Idle )], ); if (-e $user->filename) { eval { $user->load }; if ($@) { # This really shouldn't ever happen. my $t = localtime; - $kernel->post('Logger', 'error', "<$t> Error loading ${uid}: $@"); + $kernel->post('Logger', 'error', "<$t> Error loading ${id}: $@"); $kernel->yield('die', 'impossible', [$t]); return; } - $kernel->yield('auth', $uid, $user); + $kernel->yield('auth', $id, $user); } else { - $kernel->yield('accept', $uid, $user); + $kernel->yield('accept', $id, $user); } } } } - -#> CANT($want) +#> [CANT] +#> C: CANT $want +#> S: ... sub cmd_CANT { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; my $want = $args->[0]; @@ -132,11 +154,15 @@ } $heap->{want} = undef; } else { - $kernel->yield('die', 'cant.stupid' => [$want, $heap->{want}]); + $kernel->yield('die', 'cant.insane' => [$want, $heap->{want}]); } } -#> AUTH($method) +#> [AUTH] +#> C: AUTH $method ... +#> S: WANT AUTH:uc($method) ... +#> Errors: +#> * unknown -- auth method %1 is unknown sub cmd_AUTH { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; my $method = $args->[0]; @@ -146,50 +172,33 @@ if ($method eq 'pass') { $kernel->yield('want', 'AUTH:PASS'); } else { - $kernel->yield('die', 'auth', [$method]); + $kernel->yield('fail', 'AUTH', 'unknown', [$method]); + $kernel->yield('want', 'IDENT'); } } -#> AUTH:PASS($password) +#> [AUTH:PASS] +#> C: AUTH:PASS $password +#> S: ACCEPT $id +#> Errors: +#> * nomatch -- password did not match, sub cmd_AUTH_PASS { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; my ($pass) = @$args; my $user = delete $heap->{want_data}{user}; - my $uid = delete $heap->{want_data}{uid}; + my $id = delete $heap->{want_data}{uid}; return if $heap->{login}; if ($pass eq $user->get('.password')) { - $kernel->yield('accept', $uid, $user); + $kernel->yield('accept', $id, $user); } else { - $kernel->yield('die', 'auth.pass', [$uid]); + $kernel->yield('fail', 'AUTH:PASS', 'nomatch', []); + $kernel->yield('bye', 'monkeys'); } } -#> IN($cid, @rest) -sub cmd_IN { - my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; - my $cid = shift @$args; - my $cmd = shift @$args; - - $heap->{scope}{cid} = $cid; - $kernel->call($_[SESSION], "cmd_$cmd", $args); - delete $heap->{scope}{cid}; -} - -#> TO($uid, @rest) -sub cmd_TO { - my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; - my $uid = shift @$args; - my $cmd = shift @$args; - - $heap->{scope}{uid} = $uid; - $kernel->call($_[SESSION], "cmd_$cmd", $args); - delete $heap->{scope}{uid}; -} - -#> MARK($mark, @rest) sub cmd_MARK { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; my $mark = shift @$args; @@ -200,164 +209,180 @@ delete $heap->{scope}{mark}; } -#> MSG($type, @args) + +#> [MSG] +#> C: MSG $cid $type @args +#> S: MSG $cid $uid $type @args +#> Errors: +#> * syntax -- the cid %1 is invalid. +#> * notfound -- the cid %1 was not found. sub cmd_MSG { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; + my ($cid, $type) = (shift @$args, shift @$args); + my $chan = check_cid($cid, 'MSG') or return; + my $users = $chan->contents('user'); $heap->{user}->set(_last => time); - if ($heap->{scope}{cid}) { - my $chan = check_cid($heap->{scope}{cid}) or return; - my $users = $chan->list_vals('user'); - $kernel->post('Broadcaster', 'send', $users, [ - 'IN', $heap->{scope}{cid}, - 'OF', $heap->{uid}, 'MSG', @$args]); - } elsif ($heap->{scope}{uid}) { - my $user = check_uid($heap->{scope}{uid}) or return; - $user->put(['OF', $heap->{uid}, 'MSG', @$args]); - } else { - #return unless check_perm_access($heap->{user}, 'global msg'); - #my $users = $Registry->list_vals('user'); - #$kernel->post('Broadcaster', 'send', $users, ['OF', $heap->{uid}, 'MSG', @$args]); - } + + $kernel->post('Broadcaster', 'send', $users, + ['MSG', $chan->id, $heap->{uid}, $type, @$args]); } +#> [PMSG] +#> C: PMSG $uid $type @args +#> S: PMSG $uid $type @args +#> Errors: +#> * syntax -- the uid %1 is invalid. +#> * notfound -- the uid %1 was not found. +sub cmd_PMSG { + my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; + my $uid = shift @$args; + my $user = check_uid($uid, 'PMSG') or return; + + $heap->{user}->set(_last => time); -#> JOIN($cid) + $user->put(['PMSG', $heap->{uid}, @$args]); +} + +#> [JOIN] +#> C: JOIN $cid +#> S: JOIN $cid $uid +#> Errors: +#> * notfound -- the cid %1 was not found. +#> * syntax -- the cid %1 is invalid. +#> * joined -- tried to join %1 while already in it. sub cmd_JOIN { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; - my ($cid) = @$args; + my $cid = shift @$args; + my $chan = check_cid($cid, 'JOIN') or return; my $user = $heap->{user}; - - return unless check_cid($cid); - # Don't join if already in the channel. - unless ($user->contains('channel', $cid)) { - my $chan = $Registry->fetch('channel', $cid); - ASSERT: defined $chan and ref $chan; - $chan->add($user); - $user->add($chan); - my $uids = $chan->list_ids('user'); - $kernel->post('Broadcaster', 'send', $uids, - ['IN', $cid, 'OF', $heap->{uid}, 'JOIN'], - ); - } else { - # ERROR: insane.join You can't join a channel twice... - $kernel->yield('warn', 'insane.join' => [$cid]); + if ($chan->contains('user', $heap->{uid})) { + $kernel->yield('fail', 'JOIN', joined => [$cid]); + return; } + + $chan->add($user); + $user->add($chan); + my $users = $chan->contents('user'); + $kernel->post('Broadcaster', 'send', $users, ['JOIN', $cid, $user->id]); } -#> PART($cid) +#> [PART] +#> C: PART $cid +#> S: PART $cid $uid +#> Errors: +#> * notfound.cid -- the cid %1 was not found. +#> * syntax.cid -- the cid %1 is invalid. +#> * timetravel -- you tried to part %1 before you joined it... sub cmd_PART { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; - my ($cid) = @$args; + my $cid = shift @$args; + my $chan = check_cid($cid, 'PART') or return; my $user = $heap->{user}; - my $uid = $heap->{uid}; - - return unless check_cid($cid); - if ($user->contains('channel', $cid)) { - my $chan = $Registry->fetch('channel', $cid); - my $uids = $chan->list_ids('user'); - $kernel->post('Broadcaster', 'send', $uids, ['IN', $cid, 'OF', $uid, 'PART']); - $chan->remove($user); - $user->remove($chan); - } else { - # ERROR: insane.part You can't part a channel you're not in... - $kernel->yield('warn', 'insane.part' => [$cid]); + + unless ($chan->contains('user', $heap->{uid})) { + $kernel->yield('fail', 'PART', timetravel => [$cid]); + return; } -} + my $users = $chan->contents('user'); -#> USERS() -sub cmd_USERS { - my ($kernel, $heap) = @_[KERNEL, HEAP]; - - my $chan = $Registry; - my @p = (); - if ($heap->{scope}{cid}) { - $chan = $Registry->fetch('channel', $heap->{scope}{cid}); - @p = ('IN', $heap->{scope}{cid}); - } - - $heap->{socket}->put([EMAIL PROTECTED], 'USERS', $chan->list_ids('user')]); + $kernel->post('Broadcaster', 'send', $users, ['PART', $cid, $user->id]); + $chan->remove($user); + $user->remove($chan); } -sub cmd_CHANS { - my ($kernel, $heap) = @_[KERNEL, HEAP]; - $heap->{socket}->put(['CHANS', $Registry->list_ids('channel')]); -} - -#> QUIT($why) -sub cmd_QUIT { +#> [BYE] +#> C: BYE [$reason] +#> S: BYE ACTIVE [$reason] +sub cmd_BYE { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; $kernel->yield('shutdown', 'ACTIVE', @$args); } -#> INFO() +#> [INFO] +#> C: INFO $ns $id +#> S: INFO $ns $id (list of key value pairs) +#> Errors: +#> * notfound -- the id %2 of namespace %1 was not found. +#> * syntax -- the id %2 of namespace %1 is invalid. sub cmd_INFO { my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; - my ($targ, $chan); - my @in = (); - my @mark = (); + my ($ns, $id) = @$args; + my $obj = check_id($ns, $id, 'INFO') or return; + + my @keys = eval { @{ $obj->get('_info') } }; + my @out = ('INFO', $ns, $id, map { ($_ => $obj->get($_)) } @keys); - if ($heap->{scope}{mark}) { - @mark = ('MARK', $heap->{scope}{mark}); - } + $heap->{socket}->put([EMAIL PROTECTED]); +} + +#> [LINFO] +#> C: LINFO $cid $ns $id +#> S: LINFO $cid $ns $id (key-value pairs) +#> Errors: +#> * notfound -- the ns/id combination %1/%2 was not found. +#> * notfound.cid -- the cid %1 was not found. +#> * syntax -- the id %2 of namespace %1 is invalid. +#> * syntax.cid -- the cid %1 is invalid. +sub cmd_LINFO { + my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0]; + my ($cid, $ns, $id) = @$args; + my $chan = check_cid($cid, 'LINFO', 'cid') or return; - if ($heap->{scope}{cid}) { - $chan = check_cid($heap->{scope}{cid}) or return; - @in = ('IN', $chan->id); + my @m = $heap->{scope}{mark} ? ('MARK', $heap->{scope}{mark}) : (); + + if ($id ne '*') { + my $user = check_id($ns, $id, 'LINFO') or return; + + my @keys = @{ $user->get('_info') }; + my @out = (@m, 'LINFO', $cid, $id, map { ($_ => $user->get($_)) } @keys); + + $heap->{socket}->put([EMAIL PROTECTED]); } else { - $chan = $Registry; - } - - if ($heap->{scope}{uid} eq '*') { - my @users = $chan->list_vals('user'); - foreach my $user (@users) { - my @info = map { ($_ => $user->get($_)) } grep(/^[A-Z]/, $user->list_fields); - $heap->{user}->put([EMAIL PROTECTED], 'OF', $user->id, @in, 'INFO', @info]); + foreach my $user ($chan->contents('user')) { + my @keys = @{ $user->get('_info') }; + my @out = (@m, 'LINFO', $cid, $user->id, map { ($_ => $user->get($_)) } @keys); + $heap->{socket}->put([EMAIL PROTECTED]); } - } elsif ($heap->{scope}{uid}) { - my $user = check_uid($heap->{scope}{uid}) or return; - my @info = map { ($_ => $user->get($_)) } grep(/^[A-Z]/, $user->list_fields); - $heap->{user}->put([EMAIL PROTECTED], 'OF', $user->id, @in, 'INFO', @info]); } } + +sub err { + my ($s, $d) = @_; + + return $d ? "$s.$d" : $s; +} -sub check_uid { - my $uid = shift; - my $in = shift; +sub check_id { + my ($ns, $id, $cmd, $arg, $d) = @_; + $arg ||= [$id]; - - # ERROR: syntax.id Badly formed identifier. - unless (defined $uid and Haver::Server::Object::User->is_valid_id($uid)) { - $poe_kernel->yield('warn', 'syntax.id.user' => [$uid], $in); + unless (Haver::Server::Object->is_valid_id($id)) { + $poe_kernel->yield('fail', $cmd, err('syntax', $d), $arg); return undef; } - - unless ($uid eq '.' or $Registry->contains('user', $uid)) { - $poe_kernel->yield('warn', 'notfound.user' => [$uid], $in); + unless ($Registry->contains($ns, $id)) { + $poe_kernel->yield('fail', $cmd, err('notfound', $d), $arg); return undef; } - return $Registry->fetch('user', $uid); + return $Registry->fetch($ns, $id); } sub check_cid { - my $cid = shift; - - unless (defined $cid and Haver::Server::Object::Channel->is_valid_id($cid)) { - $poe_kernel->yield('warn', 'syntax.id.channel' => [$cid]); - return undef; - } + my ($id, $cmd, $rest, $d) = @_; - unless ($Registry->contains('channel', $cid)) { - $poe_kernel->yield('warn', 'notfound.channel' => [$cid]); - return undef; - } + check_id('channel', $id, $cmd, $rest, $d); +} - return $Registry->fetch('channel', $cid); +sub check_uid { + my ($id, $cmd, $rest, $d) = @_; + + check_id('user', $id, $cmd, $rest, $d); } 1; Modified: trunk/main/server/lib/Haver/Server/POE/Connection.pm =================================================================== --- trunk/main/server/lib/Haver/Server/POE/Connection.pm 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/main/server/lib/Haver/Server/POE/Connection.pm 2004-08-08 22:46:47 UTC (rev 342) @@ -60,7 +60,7 @@ want => 'on_want', cleanup => 'on_cleanup', 'shutdown' => 'on_shutdown', - 'warn' => 'on_warn', + 'fail' => 'on_fail', 'die' => 'on_die', 'accept' => 'on_accept', auth => 'on_auth', @@ -99,6 +99,8 @@ ); %$heap = ( + address => $address, + port => $port, timer => $timer, socket => $sock, shutdown => 0, @@ -108,13 +110,6 @@ user => undef, uid => undef, ); - - $sock->put(['HAVER', 3, 2048]); - $kernel->yield('want', 'IDENT', - address => $address, - port => $port, - ); - } sub _stop { my ($kernel, $heap, $session) = @_[KERNEL, HEAP, SESSION]; @@ -178,12 +173,12 @@ } } - if ($heap->{user} or $want or $cmd eq 'CANT') { - $heap->{scope} = { - }; + if ($heap->{user} or $want or $cmd eq 'CANT' or $cmd eq 'HAVER') { + $heap->{scope} = {}; $kernel->yield("cmd_$cmd", $args); } else { - $kernel->yield('die', 'SPEEDY'); + $heap->{socket} = undef; + $kernel->yield('cleanup', 'SPEEDY'); } } @@ -208,14 +203,16 @@ sub on_unknown_cmd { my ($kernel, $heap, $event, $args) = @_[KERNEL, HEAP, ARG0, ARG1]; - $kernel->yield('warn', UCMD => [$event], $heap->{scope}{cid}); + + + $heap->{socket}->put(['WARN', 'unknown.command', $event]); } sub on_shutdown { my ($kernel, $heap, $session, @args) = @_[KERNEL, HEAP, SESSION, ARG0 .. $#_]; return if $heap->{shutdown}; - $heap->{socket}->put(['BYE', @args]); + eval { $heap->{socket}->put(['BYE', @args]) }; $heap->{shutdown} = 1; $kernel->yield('cleanup', @args); } @@ -264,11 +261,10 @@ push(@users, $chan->list_ids('user')); } my %users = map { ($_ => $_) } @users; - my $msg = ['OF', $uid, 'QUIT', @args]; + my $msg = ['QUIT', $uid, @args]; $kernel->post('Broadcaster', 'send', [ keys %users ], $msg); } if ($user) { - ($heap->{port}, $heap->{address}) = $user->get('_port', '_address'); $user->save if $user->has('_reg'); } } else { @@ -277,7 +273,7 @@ } sub on_die { - my ($kernel, $heap, $err, $data, $in) = @_[KERNEL, HEAP, ARG0 .. $#_]; + my ($kernel, $heap, $err, $data) = @_[KERNEL, HEAP, ARG0 .. $#_]; if (not defined $data) { $data = []; @@ -287,12 +283,11 @@ $data = [$data]; } - my @p = $in ? (IN => $in) : (); - eval { $heap->{socket}->put([EMAIL PROTECTED], 'DIE', $err, @$data]) }; + eval { $heap->{socket}->put(['DIE', $err, @$data]) }; $kernel->yield('shutdown', 'DIE'); } -sub on_warn { - my ($kernel, $heap, $err, $data, $in) = @_[KERNEL, HEAP, ARG0 .. $#_]; +sub on_fail { + my ($kernel, $heap, $cmd, $err, $data) = @_[KERNEL, HEAP, ARG0 .. $#_]; if (not defined $data) { $data = []; @@ -302,9 +297,8 @@ $data = [$data]; } - my @p = $in ? (IN => $in) : (); - $kernel->post('Logger', 'warn', "Warning $heap->{uid}: $err"); - eval { $heap->{socket}->put([EMAIL PROTECTED], 'WARN', $err, @$data]) }; + $kernel->post('Logger', 'fail', "failing $heap->{uid} with $cmd - $err"); + eval { $heap->{socket}->put(['FAIL', $cmd, $err, @$data]) }; } sub on_accept { @@ -316,7 +310,7 @@ $Registry->add($user); $heap->{user} = $user; $heap->{uid} = $uid; - my $addr = join('.', (split(/\./, $heap->{want_data}{address}))[0,1,2]) . '.*'; + my $addr = join('.', (split(/\./, $heap->{address}))[0,1,2]) . '.*'; my $login_time = time; $user->set( IP => $addr, @@ -328,9 +322,7 @@ my ($u) = @_; time - $u->get('_last'); }, - '.IP' => $heap->{want_data}{address}, - _address => delete $heap->{want_data}{address}, - _port => delete $heap->{want_data}{port}, + '.IP' => $heap->{address}, ); delete $heap->{want_data}; $heap->{login} = 1; Modified: trunk/main/server/lib/Haver/Server/POE.pm =================================================================== --- trunk/main/server/lib/Haver/Server/POE.pm 2004-08-08 22:30:41 UTC (rev 341) +++ trunk/main/server/lib/Haver/Server/POE.pm 2004-08-08 22:46:47 UTC (rev 342) @@ -38,7 +38,7 @@ use Haver::Util::Reload; -our $VERSION = 0.06; +our $VERSION = 0.07; my %Default = ( logger => { Copied: trunk/web (from rev 341, branches/protocol-v4/web)
