diff options
51 files changed, 13849 insertions, 0 deletions
@@ -0,0 +1,372 @@ +* fix for basefork.pm IO::Select property has_exception is very platform dependent + by ignoring it altogether things actually work better. Especially on Solaris which + does have propper support for has_exception as oposed to linux. -- Niko Tyni <ntyni *iki.fi> + +2005/1/30 -- 1.38 + +* fixed error messages for environments with mixed ipv6 and ipv4 setups -- Peter W. Osel <pwo *Infineon.COM> +* fixed smoke coloring for 5 pings problem -- Tobi +* fixed User-Agent example in Curl probe -- Sebastian Wiesinger <smokeping *tracker.fire-world.de> + +2005/1/12 -- 1.37 + +* base class did assume that concurrent probes were off by default + -- Niko Tyni <ntyni *iki.fi> + +2005/1/7 -- 1.36 (1.35 was an internal release) + +* concurrent probes are default now, together with + a 'random' offset to make sure not all smokepings hit the net + at the same time -- Tobi +* fixes for loggin -- Niko Tyni <ntyni *iki.fi> + - warn if no logging method is active while daemonizing. + - turn debugging on before loading the config file. + - make do_debuglog a no-op if $use_debuglog isn't set + - add debug info to FPing* probes + - print the RRD create and update strings when debugging +* Allow probe- and target-specific number of pings -- Niko Tyni <ntyni *iki.fi> +* RemoteFPing probe revisited and fixed. Note this probe allowed + PROBE_CONF config where this was technically not possible. Now these settings + are done in the ***Probes*** section ... you have to fix your + config files -- Niko Tyni <ntyni *iki.fi> +* fixed many typos and some seemingly numeric comparisons -- Niko Tyni <ntyni *iki.fi> +* new feature 'concurrentprobes' allow to run multiple probes in paralell and at different step + width. -- Niko Tyni <ntyni *iki.fi> +* allow to define multiple instances of a sigle probe -- Niko Tyni <ntyni *iki.fi> +* fix --filter again ... pathprefix was still in there -- tobi + +2004/11/29 -- 1.34 (1.32 + 1.33 were internal only releases) + +* added SNPP support as suggested by jdelisle -- tobi +* added ipv6 support to EchoPing probe -- Niko Tyni <ntyni *iki.fi> +* fix for Radius probe -- Niko Tyni <ntyni *iki.fi> +* added new alert plugins called matchers -- tobi +* created matcher::avgratio sponsored by virtela.net -- tobi +* make --filter option actually work -- tobi +* removed maxmedian magic regexp ... -- tobi +* added new alert type matcher -- tobi +* fixed pod errors -- Niko Tyni <ntyni *iki.fi> +* allow to mix programs and email addresses in alerts --tobi +* allow to define recipient per alert --tobi + +2004/08/04 -- 1.31 + +* added anotherdns and anotherssh probes -- Christoph.Heine *HaDiKo.DE +* modify FPing probes to skip ICPM errors in the output -- Tobi +* modify RemoteFPing probe to work with normal fping that outputs + via stderr. -- Tobi +* allow timeout to be specified in base::forks based probes -- Tobi +* Added ssh probe -- Christian Recktenwald <smokeping-contact *citecs.de> + +2004/05/12 -- 1.30 + +* fix nodata_color syntax --tobi + +* when inserting unknown values into sorted rtt list, do this on the outside + ... U:U:1:2:3:U:U and not in the middle. This will make the graphs more + smokei when there is data loss. --tobi + +* config files with different probes should work ... fixed problem introduced in 1.29 --tobi + +2004/05/08 -- 1.29 +* while running, make all die and warn things go to the log file if there is one --tobi +* added rawlog option for logging actual gatherd data --tobi (for virtela) +* added alertee option to send a copy of any alert generated to additional 'per branche' people --tobi +* cgi should not complain about non existing hosts ... the daemon does that already --tobi +* actually allow empty alerts -- tobi + +* added nodata_color property to specify background color for graph when + when no data is available -- David Hull <hull *dslextreme.com> + +2004/03/14 -- 1.28 +* do not repeat last rounds rtts in basefork if probe gets killed on timeout -- Niko Tyni <ntyni *iki.fi> + +2004/03/09 -- 1.27 +* allow . in labels -- Tobi +* fix mkdir with missing permissions -- Xander Jansen <Xander.Jansen *surfnet.nl> +* make echoping probes complain when they do not get a 0 return value -- Tobi +* make manu and title = host if not set -- tobi +* forbid . in section names .. bad things will happen when used. -- tobi +* patches for the Radius and LDAP probes -- Niko Tyni <ntyni *cc.helsinki.fi> +* prevent requests to non existing pages -- tobi + +2004/02/16 -- 1.26 +* contributed radius and ldap probes -- Niko Tyni <ntyni *cc.helsinki.fi> +* added new 'offset' parameter to config file which allows to shift startup + time of smokeping polling -- Tobi (for Virtela) +* new option --static-pages to generate a static website (mrtg like) -- Santeri Paavolainen <santtu *iki.fi> +* added support for multiple alert recipients -- Dmitry Melekhov <dm *belkam.com> +* fix for telnetIOSping.pm to consider packet size -- Paul Wulff <paul.wulff *ap.marconi.com> +* added --logfile option and generally enhanced logging ... + smokeping will not die and log instead. -- Tobi + +2004/01/04 -- 1.25 +* enhaced Alert patterns: S for matching at startup + *X* pattern for timeshift matches. See docs. -- Tobi +* Added timeout option the EchoPingHttp -- Tobi +* fixed RemoteFPing probe -- Keith Patton + +2003/10/05 -- 1.24 +* The new --filter option allows you to run the smokeping deamon on a big config file, + but have the config file filtered and only measure the entries that pass + the filter. This allows to use rsync to consolidate measurements from + different hosts at a central location for presentation. -- Tobi +* new lookup option for DNS probe -- "Poetzel, Christopher J." <cpoetzel *anl.gov> +* store iaxhight info in img cache -- Curtis Doty <Curtis *GreenKey.net> +* new probes: ICMP echo response times - CiscoRTTMonEchoICMP.pm, + DNS query response times - CiscoRTTMonDNS.pm, + TCP connect times - CiscoRTTMonTcpConnect.pm -- joerg.kummer at roche.com + +2003/07/15 -- 1.23 +* added missing ; in DNS.pm + +2003/07/11 -- 1.22 + +* fix stderr redirection: David Hull <hull *dslextreme.com> +* new DNS.pm based on basefork by Igor Petrovski <pigor *myrealbox.com> and Carl Elkins <carl *celkins.org.uk> + +2003/06/17 -- 1.21 + +* keep order of targets in config file when presenting on the web -- Tobi +* fix mailsending with a b <x *y> type addresses -- Aaron Schrab <aaron *schrab.com> +* made alert feature more robust -- Tobi +* telnetiosping probe John A. Jackson <johnj *infoave.net> +* add iosint configurable to IOSPing.pm -- Mars Wei <MarsWei *ncic.com.tw> +* added RemoteFPing Probe -- Luis F Balbinot <hades *inf.ufrgs.br> + +2003/04/12 -- 1.20 + +* replaced host foo with 127.0.0.1 in Echo*.pm probes -- John Sellens <jsellens *generalconcepts.com> +* curl probe -- Gerald Combs <gerald [AT] ethereal.com> +* DNS.pm should not use external binaries besided dig -- Tobi + +2003/02/19 -- 1.19 + +* dns probe -- Andre Stolze <stolze *uni-muenster.de> +* fixed label formatting error -- Tobi + +2002/12/05 -- 1.18 + +* allow sub millisecond patterns -- Tobi + +* report a full link in smokeping alerts + suggested by "Nipper, Arnold" <arnold *nipper.de> + +2002/10/19 -- 1.17 +* Change the absolute max possible rtt to 180 seconds when creating new rrd files + +2002/10/13 -- 1.16 + +* add Hostname as a 5th argument for external alert scripts --Tobi + +* when runnning fping -i must be > 10 ... (whatever 10 is) -- Tobi + +* fix graphing in logarithmic presentation. Handle fast pings better -- Paul J Murphy <Paul *murph.org> + +* added IOSPing.pm probe -- Paul J Murphy <Paul *murph.org> + +2002/09/27 -- 1.15 + +* uptime color configuration was not working -- Alan Chen <alan *digikata.com> + +* allow to call an external script upon matching an alert pattern -- Tobi + +* unifie mail sending tools -- Tobi + +* made loss for 0.x sized values work -- rodrigo.cunha *corp.vodafone.pt + +* send syslog events through unix domain socket on bsd and linux systems -- Ed Ravin <eravin *panix.com> + + +2002/09/10 -- 1.14 + +* fixed docs ... remove alert_email property from docs --tobi + +* fixed Data output for email alerts -- tobi + + +2002/09/08 -- 1.13 + +* Added all new Alerts function. Smokeping can now match + alert patterns against the loss and rtt values gatherd + and send email when a pattern matches. -- Tobi + +* Display AVG loss in % -- Tobi + +* Add help functions back in -- Tobi + +* make graphs with large ping times graph properly. + -- Jack Cummings <jack *mudshark.org> + +* make FPing.pm handle dead hosts more gracefully + '-B1','-i'. int($self->{pingfactor}/1000),'-r1' --Tobi + +2002/05/29 -- 1.12 +* make probes announce themselves at startup + -- Niko Tyni <ntyni *cc.helsinki.fi> + +* really ... log full loss if no pings get through ... -- Tobi +* allow FPing probe to take packetsize option -- Tobi + +2002/05/08 -- 1.11 +* If no pings get trough, log a full loss and not unknown loss -- tobi +* have a timeout to prevent hanging echoping processes + -- Niko Tyni <ntyni *cc.helsinki.fi> +* allow logging via syslog + -- Niko Tyni <ntyni *cc.helsinki.fi> + +2002/05/06 -- 1.10 + +* added avg loss to graphs -- tobi + +2002/04/29 -- 1.9 + +* added Fping6 by Elmar Hoffmann <elho *elho.net> +* added description about installing EchoPing, Fping and sock6 to + install notes +* do not test for FPing binary when running as a cgi + +2002/04/24 -- 1.8 + +* make sure smokeping.cgi manages to show its errors on the web. + +2002/04/12 -- 1.7 + +* complain if fping is not seuid root -- tobi + +* kill one div zero bug -- Jan Ludewig <chaot *isch.de> + +2002/03/27 -- 1.6 + +* fixed bug in monitoring function where targets that + had subtargets on the same level were ignored ... -- tobi + +* in basefork.pm test if IO::Select knows has_error() but not + has_exception() -- Jan Ludewig <chaot *isch.de> + +* improve handling of PID file, cases where it could not be read or written + wer not handlie gracefully -- Jan Ludewig <chaot *isch.de> + +* remove --help and --man option they never worked ... + +2002/03/10 -- 1.5 + +* missed one module in the distribution ... + +2002/03/09 -- 1.4 + +* make sure FPing does not hand if no targets are defined. + +* new mandatory config option piddir to specify where the pid file + should be -- Jose Carlos Garcia Sogo <jsogo *debian.org> + **** INCOMPATIBLE CHANGE **** + +* EchoPing probes contributed by Niko Tyni <ntyni *cc.helsinki.fi> + there is a webpage on http://www.helsinki.fi/~ntyni/smokeping/ + +2002/03/01 -- 1.3 + +* fixed messed up links in distribution archive ... + +2002/03/01 -- 1.2 + +* improve error messages in probe setup + +* be smarter about detecting fping reporting unit. -- Kai <spdev *vega.fur.com> + +2002/02/12 -- 1.1 + +* make detailed view colors work even if number of pings is not even + ++INCOMPATIBLE CHANGE+ modified the definition of smokelogo and rrdlogo in the + webtemplate file. he tags now provide the image tage and the anchor + around. Please modify your template accordingly + +* Toby Weingartner provided some patches to clean up error messages + +* removed default sites from config file to protect the innocent. + +* detect probe loading failiours + +2002/02/09 -- 1.0 + +* made basepage links stand out ... + +2002/01/31 -- 0.99.18 +* Fixed loss color config handling and documentation + +2002/01/28 -- 0.99.17 +* Get description of Ping from Probe +* Fixed quote parsing in config parser + +2002/01/27 -- 0.99.16 +* fixed unison scaling ... I was picking the wrong value as median. +* do not refuse to start if a host is missing from DNS ... just complain + +2002/01/27 -- 0.99.15 +* now the color works you have to use rrggbb not #rrggbb +* added scrftime configurable to format time in lower + righthand corner of the graph + + +2002/01/27 -- 0.99.14 +* guess [0-f] does not work it should be [0-9a-f] + +2002/01/26 -- 0.99.13 +* switched back to normal scaling for overview graphs +* added average and latest median rtt numbers to graph +* added more color settings to graph +* allow configuration of loss and uptime colors (not tested) + +2002/01/23 -- 0.99.12 +* Use -alt-y-scaling for better grid in overview graphs +* Added max_rtt to overview graphs + +2002/01/22 -- 0.99.11 + +* files which must be modified are now named *.dist (thanks paul) +* added maxrtt configurable +* introduced new colors for link uptime using INF +* added thin black line 'connecting the 'measurements' + +2002/01/20 -- 0.99.10 + +* Added cache file for graph.max values ... this will improve unison scaling + in lazy mode +* changed drawing of madian to AREA and STACK to take into account that this + is not anything contious we are looking at but samples ... + + +2002/01/17 -- 0.99.9 + +* allow --nodaemon as well +* added new configurables lograrithic and unison_tolerance + this should help smokeping deal better with spikes + +2002/01/03 -- 0.99.8 +* Change colors for LOSS display ... make small losses simpler to see +* Sort Graphs in Overview +* --nodemon option +* Allow cgi urls with https:// + +2001/11/17 -- 0.99.7 + +* Make DYNAMIC work with hosts who do not support snmp +* do not print anything from FPing.pm if used from CGI + +2001/11/03 -- 0.99.6 + +* updated the default basepage.html to include automatic reload and cache expiery ... -- Me +* smokeping.cgi adds header information to the webpage with expiery and charset -- Me +* split the pod docs off the smokeping and smokeping.cgi scripts -- Me +* created a special version of fping where configure works ... added it to the + download area of smokeping. -- Me +* spell fixes for Smokepin.pm (smokeping_config.pod) -- S. William Schulz <ss *ssLinux.com> + +2001/11/01 -- 0.99.5 + +* Deal with nan as well as NaN -- Me +* Deal with DYNAMIC hosts who do not allow for SNMP -- Me +* mkdir needs a mode (0755) -- S. William Schulz <ss *ssLinux.com> +* Determine is fping reports in miliseconds or in 0.1 miliseconds -- Me +* Wait for 3 seconds when restarting ... diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 index 0000000..90973d3 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,9 @@ +Contributors +============ + +* Tobias Oetiker <tobi@oetiker.ch> => Main Author + +* Niko Tyni <ntyni@cc.helsinki.fi> => Many Patches +* Simon Leinen <leinen@switch.ch> => SNMP_Session.pm +* David Schweikert <dws@ee.ethz.ch> => ISG::ParseConfig.pm +* Jack Cummings <jack@mudshark.org> => Proper graphs with pings > 10s. @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) 19yy <name of author> + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19yy name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + <signature of Ty Coon>, 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 index 0000000..1426711 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,22 @@ + SmokePing - a ICMP latency logging and graphing + system. It consists of a daemon process which + organizes the latency measurements and a CGI which + presents the graphs. + + Copyright (c) 2001 Tobias Oetiker <tobi@oetiker.ch> + + All rights reserved. + + This program is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by the Free + Software Foundation; either version 2 of the License, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, but WITHOUT + ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or + FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for + more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., 675 + Mass Ave, Cambridge, MA 02139, USA. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..fd96fd6 --- /dev/null +++ b/Makefile @@ -0,0 +1,76 @@ +SHELL = /bin/sh +VERSION = 1.38 +IGNORE = ~|CVS|var/|smokeping-$(VERSION)/smokeping-$(VERSION)|cvsignore|rej|orig|DEAD +GROFF = groff +.PHONY: man html txt ref patch killdoc doc tar +.SUFFIXES: +.SUFFIXES: .pm .pod .txt .html .man .1 + +POD := doc/$(wildcard doc/*.pod) lib/ISG/ParseConfig.pm \ + lib/Smokeping.pm +PODPROBE := lib/probes/$(wildcard lib/probes/*.pm) +PODMATCH := lib/matchers/$(wildcard lib/matchers/*.pm) + +BASE = $(addprefix doc/,$(subst .pod,,$(notdir $(POD)))) $(addprefix doc/probes/,$(subst .pod,,$(notdir $(PODPROBE)))) $(addprefix doc/matchers/,$(subst .pod,,$(notdir $(PODMATCH)))) +MAN = $(addsuffix .1,$(BASE)) +TXT = $(addsuffix .txt,$(BASE)) +HTML= $(addsuffix .html,$(BASE)) + +POD2MAN = pod2man --release=$(VERSION) --center=SmokePing $< > $@ +POD2HTML= cd doc ; pod2html --infile=../$< --outfile=../$@ --noindex --htmlroot=. --podroot=. --podpath=. --title=$* +doc/%.1: doc/%.pod + $(POD2MAN) +doc/%.1: lib/% + $(POD2MAN) +doc/probes/%.1: lib/probes/% + $(POD2MAN) +doc/matchers/%.1: lib/matchers/% + $(POD2MAN) +doc/%.1: lib/ISG/% + $(POD2MAN) + +doc/%.html: doc/%.pod + $(POD2HTML) +doc/%.html: lib/% + $(POD2HTML) +doc/%.html: lib/ISG/% + $(POD2HTML) +doc/probes/%.html: lib/probes/% + $(POD2HTML) +doc/matchers/%.html: lib/matchers/% + $(POD2HTML) + +doc/%.txt: doc/%.1 + $(GROFF) -man -Tascii $< > $@ +doc/matchers/%.txt: doc/matchers/%.1 + $(GROFF) -man -Tascii $< > $@ +doc/probes/%.txt: doc/probes/%.1 + $(GROFF) -man -Tascii $< > $@ + +man: $(MAN) + +html: $(HTML) + +txt: $(TXT) + +ref: doc/smokeping_config.pod + +doc/smokeping_config.pod: lib/Smokeping.pm + perl -Ilib -I/usr/pack/rrdtool-1.0.47-to/lib/perl -mSmokeping ./bin/smokeping.dist --makepod > doc/smokeping_config.pod +patch: + perl -i~ -p -e 's/VERSION="\d.*?"/VERSION="$(VERSION)"/' lib/Smokeping.pm + perl -i~ -p -e 's/Smokeping \d.*?;/Smokeping $(VERSION);/' bin/smokeping.dist htdocs/smokeping.cgi.dist + +killdoc: + -rm doc/*.1 doc/*.txt doc/*.html + +doc: killdoc ref man html txt + +tar: doc patch + -ln -s . smokeping-$(VERSION) + find smokeping-$(VERSION)/* -type f -follow -o -type l | egrep -v '$(IGNORE)' | gtar -T - -czvf smokeping-$(VERSION).tar.gz + rm smokeping-$(VERSION) + +dist: tar + mv smokeping-$(VERSION).tar.gz /home/oetiker/public_html/webtools/smokeping/pub/ + cp CHANGES /home/oetiker/public_html/webtools/smokeping/pub/CHANGES @@ -0,0 +1,61 @@ + ____ _ ____ _ +/ ___| _ __ ___ ___ | | _____| _ \(_)_ __ __ _ +\___ \| '_ ` _ \ / _ \| |/ / _ \ |_) | | '_ \ / _` | + ___) | | | | | | (_) | < __/ __/| | | | | (_| | +|____/|_| |_| |_|\___/|_|\_\___|_| |_|_| |_|\__, | + |___/ +Author: Tobias Oetiker <tobi@oetiker.ch> + + SmokePing is a latency logging and graphing + system. It consists of a daemon process which + organizes the latency measurements and a CGI which + presents the graphs. + + +SmokePing is ... +================ + + * quite fast because it uses FPing todo the actual pinging + + * easy to customize through a webtemplate and an extensive + configuration file. + + * written in perl and should readily port to any unix system + + * extensible through plug-in modules + + * an RRDtool frontend + + * able to deal with DYNAMIC IP addresses as used with + Cable and ADSL internet. + +Roadmap +======= + +SmokePing comes with documentation to make it easy to use and +install. The following important documentation files are +included with SmokePing: + + + * doc/smokeping_install.txt -- How to Setup and Install + * doc/smokeping_config.txt -- Description of the Config File + * doc/smokeping.txt -- About the SmokePing Daemon + * doc/smokeping.cgi.txt -- About the CGI Module + +In the doc directory you can find even more information +and the above documents in MAN, POD, TXT and HTML format. + +Do you like it +============== + +If you like SmokePing, and want to show your appreciation for +the work I am doing (SmokePing like MRTG and RRDtool have +been written entirely in my spare time) please feel free to +use: + + http://people.ee.ethz.ch/~oetiker/wish + + +Cheers +tobi + @@ -0,0 +1,11 @@ +* UPTIME + define update via snmp pointer per device + +* ATTENTION + allow to define a thereshold rule by looking at + two average medians and take action when threshold triped + +* ALIASES + allow to have atarget which points to a different target + only targets with host are considered + diff --git a/bin/smokeping.dist b/bin/smokeping.dist new file mode 100755 index 0000000..701e3a6 --- /dev/null +++ b/bin/smokeping.dist @@ -0,0 +1,148 @@ +#!/usr/sepp/bin/perl-5.8.0 -w +# -*-perl-*- + +use lib qw(/usr/pack/rrdtool-1.0.47-to/lib); +use lib qw(/home/oetiker/data/projects/AADJ-smokeping/dist/lib); + +use Smokeping 1.38; + +Smokeping::main("etc/config.dist"); + +=head1 NAME + +smokeping - Commandline tool for SmokePing + +=head1 SYNOPSIS + +B<smokeping> [ B<--email> | B<--makepod> | B<--version> | B<--restart> ] + + Options: + + --man Show the manpage + + --help Help :-) + + --email Send SmokePing Agents to all Targets marked DYNAMIC + + --makepod Create POD documentation on Config file + + --version Show SmokePing Version + + --debug Run Only once and do not Fork + + --debug-daemon Start the daemon with debugging enabled + + --restart Restart SmokePing + + --nodaemon Do no daemonize the process (no fork) + + --filter=x Only measure entries which pass the filter x + + --logfile Append warnings to this logfile + + --static[=x] Generates a static website in directory x. If x is left out, + pagedir from the config is used. + + --nosleep For debugging you may want to run SmokePing without sleep interval + +=head1 DESCRIPTION + +The B<smokeping> tool is the commandline part of the SmokePing system. Its +main function is to run as a daemon and send Pings to all the Targets you +have specified in the Config file. When you call B<smokeping> without +arguments it will start as a daemon and do its work. + +If called with an argument, then further functions can be activated, as seen +in the Synopsis above. The B<--email> function is explained in the +documentation on the config file. + +The B<--filter> option allows you to run the daemon on a big config file, +but have the config file filtered and only measure the entries that pass the +filter. This is useful for remote measurement. Run Smokeping with two +exclusive filters in two locations and rsync the rrds back to the webserver +host where you run the cgi. Filters act on the section names in the config +file. Multiple section names are concatenated with B</> like path names: + + *** targets *** + + A + .... + + B + ... + ++ C + +This gives + + /A + +and + + /B, /B/C + +If I want to monitor /A my filter would look like this: + + --filter=/A + +Filters follow regular expression syntax. The are always anchored at the tip of the string. +by adding a B<!> to the front of the filter string you negate it. Matching entries will be excluded from monitoring. +Multiple B<--filter> arguments can be used to assemble complex filters: + + --filter=/A --filter=/B + +would include all the targets + + --filter=/A --filter=/B --filter=!/B/C + +would include all but /B/C. + +The B<--makepod> does get used internally to produce the documentation on +the SmokePing configuration file. + +Please refer to the installation document for detailed setup instructions. + +=head1 SETUP + +When installing SmokePing, this file has to be adjusted to fit your +local system. Three paths have to be entered. + +One pointing to your B<rrdtool> installation + + use lib qw(/usr/pack/rrdtool-1.0.33-to/lib/perl); + +One pointing to the place where you have installed the SmokePing libraries + + use lib qw(/home/oetiker/public_html/smokeping/lib); + +The third path is the argument to the Smokeping::main command. It points to +the SmokePing configuration file. + + use Smokeping; + Smokeping::main("/home/oetiker/.smokeping/config"); + +=head1 COPYRIGHT + +Copyright (c) 2002 by Tobias Oetiker. All right reserved. + +=head1 LICENSE + +This program is free software; you can redistribute it +and/or modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later +version. + +This program is distributed in the hope that it will be +useful, but WITHOUT ANY WARRANTY; without even the implied +warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +PURPOSE. See the GNU General Public License for more +details. + +You should have received a copy of the GNU General Public +License along with this program; if not, write to the Free +Software Foundation, Inc., 675 Mass Ave, Cambridge, MA +02139, USA. + +=head1 AUTHOR + +Tobias Oetiker E<lt>tobi@oetiker.chE<gt> + +=cut diff --git a/doc/.cvsignore b/doc/.cvsignore new file mode 100644 index 0000000..f642dd8 --- /dev/null +++ b/doc/.cvsignore @@ -0,0 +1,3 @@ +*.html +*.1 +*.txt diff --git a/doc/smokeping_install.pod b/doc/smokeping_install.pod new file mode 100644 index 0000000..0c9f803 --- /dev/null +++ b/doc/smokeping_install.pod @@ -0,0 +1,177 @@ +=head1 NAME + +smokeping_install - How to install SmokePing + +=head1 OVERVIEW + +This document explains how to setup SmokePing at your site. + +=head1 DESCRIPTION + +=head2 Prerequisites + +SmokePing does not stand alone. It relies on various other tools and +services being present. Apart from a Unix OS and a working Perl installation +you need the following things. The list contains the names of the tools +together with the version of the tool which I am using, and a link for +downloading the tool. + +=over + +=item RRDtool 1.0.x + +http://people.ee.ethz.ch/~oetiker/webtools/rrdtool/pub/rrdtool-1.0.33.tar.gz + +Just follow the installation instructions. We need this package todo all the +logging and graphing in SmokePing. + +=item FPing 2.4b2 + +http://people.ee.ethz.ch/~oetiker/webtools/smokeping/pub/fping-2.4b2_to.tar.gz + +This is a special version of fping which actually builds. I have not +modified the code in any way, I just fixed the autoconf setup. The original +can be found on http://www.fping.com/download/fping-2.4b2.tar.gz + +Note that fping must be installed setuid root. It seems that older versions +of fping report round trip times in 0.1 milliseconds instead of 1 milliseconds +as advertised ... SmokePing tries to figure this out. It tells +you when it starts ... let me know it it gets it wrong. + +=item FPing 2.4b2 IPV6 (Optional) + +http://unfix.org/projects/ipv6/fping-2.4b2_to-ipv6.tar.gz + +You need this if you want to use the FPing6 probe + +=item Socket6 0.11-1 (Optional) + +http://www.cpan.org/modules/by-module/Socket6/ + +Optionally installing the Socket6 module for perl enables +smokeping to check hostnames that only resolve to an IPv6 +address. If you probe such hosts using ie. the FPing6 probe +and get warnings that those hosts don't resolve to an IP +address, you need to install it. + +=item EchoPing (Optional) + +http://echoping.sourceforge.net/ + +You need this to run the EchoPing probes + +=item Webserver + +http://httpd.apache.org/ + +Well I wont get much into this. The important thing is, to have a webserver +which allows you to run CGI scripts. If you are using Apache I strongly +recommend using the F<suexec> system for running CGI scripts. Often it is +sufficient to change the F<suexec> binary to setuid root and restart Apache. +Using F<suexec> allow to run cgi scripts under proper user accounts. + +=item Perl 5.6.1 + +http://www.perl.com + +I guess you will get away with older versions of perl. I am using 5.6.1 here +and it works fine. + +=item SpeedyCGI + +http://daemoninc.com/speedycgi/ + +SpeedyCGI speeds up CGIs written in perl dramatically by making them memory +resident and handing new request to the script which is already running. +SmokePing has been optimized for use with SpeedyCGI. Note that you do NOT +need mod_speedy, just the plain and simple speedy executable, this is the +beauty of this tool it works without touching your apache ... Otherwise +you could as well be using FastCGI or mod_perl. + +=back + +=head2 Installation + +Once the tools listed above are in place, you can start setting up SmokePing +itself. Once the SmokePing tools are unpacked, they are more of less ready +to use. At least to the extent, that it is not necessary to B<install> them. +You may want to rename the directory to a name which does not contain the +version number of SmokePing, or at least make a symlink, so that you can use +a persistent name when referring to SmokePing files. + +In the distribution you find a number of files named F<*.dist> they have to +be edited and renamed to F<*>. Below you find a short explanation for each +of the files you have to edit: + + +=over + +=item F<bin/smokeping> + +Make sure all the required libraries are available and the first line of the +script points to your copy of perl. Adjust the B<use lib> lines to point to +your B<RRDtool> installation and to the B<Smokeping/lib> directory and edit +the path of the config file to be in sync with reality. + +=item F<htdocs/smokeping.cgi> + +Edit the F<smokeping.cgi> analog to the F<smokeping> script above. Make sure +the first line of the script is pointing to your freshly installed copy of +Speedy CGI. Store the script in a directory of your weberver where CGIs get +executed. You also have to edit the B<use lib> line similar to what you did +to F<smokeping> + +=item F<etc/config> + +Create your SmokePing configuration file. The easiest is to copy the +F<etc/config> file and work from there. Please refer to +L<smokeping_config> for details. + +=item F<etc/basepage.html> + +Edit the html template to your likings. Please do not remove the link to the +SmokePing counter and my name from the template. + +=item F<etc/smokemail> + +If you are going to use the B<DYNAMIC> IP support, customize the contents of this file. + +=back + +Now you are ready to start smokeping: + + ./bin/smokeping + +Once the system works, you may want to put a SmokePing startup script into +your F</etc/init.d> tree. Check out L<smokeping> for further information. + +When you can now also open the smokeping.cgi webpage to look at your data. + +=head1 COPYRIGHT + +Copyright (c) 2001 by Tobias Oetiker. All right reserved. + +=head1 LICENSE + +This program is free software; you can redistribute it +and/or modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later +version. + +This program is distributed in the hope that it will be +useful, but WITHOUT ANY WARRANTY; without even the implied +warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +PURPOSE. See the GNU General Public License for more +details. + +You should have received a copy of the GNU General Public +License along with this program; if not, write to the Free +Software Foundation, Inc., 675 Mass Ave, Cambridge, MA +02139, USA. + +=head1 AUTHOR + +Tobias Oetiker E<lt>tobi@oetiker.chE<gt> + +=cut diff --git a/etc/basepage.html.dist b/etc/basepage.html.dist new file mode 100644 index 0000000..f5fa3b7 --- /dev/null +++ b/etc/basepage.html.dist @@ -0,0 +1,84 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"> +<HTML> +<HEAD> +<META HTTP-EQUIV="Cache-Control" content="no-cache"> +<META HTTP-EQUIV="Pragma" CONTENT="no-cache"> +<META HTTP-EQUIV="Refresh" CONTENT="<##step##>"> +<TITLE>SmokePing Latency Page for <##title##></TITLE> +<STYLE type="text/css"> +<!-- + +.menu { color: black; + font-size: 10px; + font-family: Arial, Helvetica, Sans-Serif; + } + +.menuitem + { color: black; + font-size: 10px; + font-family: Arial, Helvetica, Sans-Serif; + } + +.menuopen + { color: black; + font-size: 10px; + font-family: Arial, Helvetica, Sans-Serif; + } + +.menuactive + { color: black; + font-size: 10px; + font-family: Arial, Helvetica, Sans-Serif; + } + +.menuactive { + color: black; + background: #aaaaff; + } + +.menulink { + color: black; + } + +.menu A:Hover { + text-decoration: none; + color: #000000; + background: silver; + } + + +--> +</STYLE> + +</HEAD> +<BODY bgcolor="white"> +<TABLE border="0" cellpadding="10" cellspacing="0"> +<TR> + <TD align="left" width="130" bgcolor="#cfcfcf" valign="top"> + <P></P> + <P><B>Select Target:</B> </P> + <P><##menu##></P> + <br> + <br> + <br> + <hr> + <br> + <p><small>Maintained by:<br/><A href="mailto:<##contact##>"><##owner##></A></small></p> + <p><small>Created using <##author##>'s <##smokeping##></small></p> + <P><##smokelogo##></P> + <P></P> + <P><##rrdlogo##></P> +</TD> + <TD></TD> + <TD valign="top"> + <H1><##title##></H1> + <P><##remark##></P> + <P><##overview##></P> + <P><##body##></P> + </TD> +</TR> +<tr><td width="130" bgcolor="#cfcfcf"> +</td><td></td><td></td></tr> +</TABLE> +</BODY> +</HTML> diff --git a/etc/config-echoping.dist b/etc/config-echoping.dist new file mode 100644 index 0000000..2aa7678 --- /dev/null +++ b/etc/config-echoping.dist @@ -0,0 +1,82 @@ +# only the relevant sections are included, see smokeping distribution +# for the rest of them + +*** Probes *** + +# these expect to find echoping in /usr/bin +# if not, you'll have to specify the location separately for each probe +# + EchoPing # uses TCP or UDP echo (port 7) +# + EchoPingDiscard # uses TCP or UDP discard (port 9) +# + EchoPingChargen # uses TCP chargen (port 19) ++ EchoPingSmtp # SMTP (25/tcp) for mail servers ++ EchoPingHttps # HTTPS (443/tcp) for web servers ++ EchoPingHttp # HTTP (80/tcp) for web servers and caches ++ EchoPingIcp # ICP (3130/udp) for caches + +*** Targets *** + +# default probe +probe = FPing + +menu = Top +title = Network Latency Grapher +remark = Welcome to the SmokePing website of xxx Company. \ + Here you will learn all abou the latency of our network. + ++ MyServers + +menu = My Servers +title = My Servers + +++ www-server +menu = www-server +title = Web Server (www-server) / ICMP +# probe = FPing propagated from top +host = www-server.abc + ++++ http +menu = http +title = Web Server (www-server) / HTTP +probe = EchoPingHttp +host = www-server.abc +# default url is / + ++++ https +menu = https +title = Web Server (www-server) / HTTPS +probe = EchoPingHttps +host = www-server.abc + +++ cache +menu = www-cache +title = Web Cache (www-cache) / ICMP +host = www-cache.abc + ++++ http +menu = http +title = www-cache / HTTP +host = www-cache.abc +probe = EchoPingHttp +++++ PROBE_CONF +port = 8080 # use the squid port +url = http://www.microsoft.com/ + ++++ icp +menu = icp +title = www-cache / ICP +host = www-cache.abc +probe = EchoPingIcp +++++ PROBE_CONF +url = http://www.microsoft.com/ + +++ mail +menu = mail-server +title = Mail Server (mail-server) / ICMP +host = mail-server.abc + ++++ smtp +menu = mail-server / SMTP +title = Mail Server (mail-server) / SMTP +host = mail-server.abc +probe = EchoPingSmtp + diff --git a/etc/config.dist b/etc/config.dist new file mode 100644 index 0000000..71560ba --- /dev/null +++ b/etc/config.dist @@ -0,0 +1,176 @@ +# Note that all IP addresses in this file are false, to prevent some +# machine falling uder a deadly DOS storm because all users keep +# the same addresses in their config. + +*** General *** + +owner = Joe Random +contact = joe@some.place.xyz +mailhost = smtp.mailhost.abc +sendmail = /usr/lib/sendmail +imgcache = /home/oetiker/public_html/.simg +imgurl = ../.simg +datadir = /home/oetiker/data/projects/AADJ-smokeping/dist/var +piddir = /home/oetiker/data/projects/AADJ-smokeping/dist/var +cgiurl = http://people.ee.ethz.ch/~oetiker/smokeping/smokeping.cgi +smokemail = /home/oetiker/data/projects/AADJ-smokeping/dist/etc/smokemail.dist +# specify this to get syslog logging +syslogfacility = local0 +# each probe is now run in its own process +# disable this to revert to the old behaviour +# concurrentprobes = no + +*** Alerts *** +to = admin@company.xy +from = smokealert@company.xy + ++bigloss +type = loss +# in percent +pattern = ==0%,==0%,==0%,==0%,>0%,>0%,>0% +comment = suddenly there is packet loss + ++someloss +type = loss +# in percent +pattern = >0%,*12*,>0%,*12*,>0% +comment = loss 3 times in a row + ++startloss +type = loss +# in percent +pattern = ==S,>0%,>0%,>0% +comment = loss at startup + ++rttdetect +type = rtt +# in milli seconds +pattern = <10,<10,<10,<10,<10,<100,>100,>100,>100 +comment = routing mesed up again ? + +*** Database *** + +step = 300 +pings = 20 + +# consfn mrhb steps total + +AVERAGE 0.5 1 1008 +AVERAGE 0.5 12 4320 + MIN 0.5 12 4320 + MAX 0.5 12 4320 +AVERAGE 0.5 144 720 + MAX 0.5 144 720 + MIN 0.5 144 720 + +*** Presentation *** + +template = /home/oetiker/data/projects/AADJ-smokeping/dist/etc/basepage.html.dist + ++ overview + +width = 600 +height = 50 +range = 10h + ++ detail + +width = 600 +height = 200 +unison_tolerance = 2 + +"Last 3 Hours" 3h +"Last 30 Hours" 30h +"Last 10 Days" 10d +"Last 400 Days" 400d + +*** Probes *** + ++ FPing + +binary = /usr/sepp/bin/fping + +*** Targets *** + +probe = FPing + +menu = Top +title = Network Latency Grapher +remark = Welcome to the SmokePing website of xxx Company. \ + Here you will learn all about the latency of our network. + ++ World + +menu = World +title = Worldwide Connectivity + +++ Europe + +menu = Europe +title =European Connectivity + ++++ Switzerland + +menu = Switzerland +title =Swiss Connectivity +alerts = bigloss,someloss,startloss + +++++ SBB + +menu = SBB/CFF/FFS +title =Swiss Federal Railways Webserver +host = www.railway-server.abc + + +++++ Tiscali + +menu = Tiscali Web +title = Tiscali Webserver www.tiscali.abc +host = www.tiscali-web.abc + ++++ UK + +menu = United Kingdom +title = United Kingdom + +++++ UCL + +menu = UCL +title = UCL +host = www.ucl-abc.acc.uk + +++ USA + +menu = North America +title =North American Connectivity + ++++ MIT + +menu = MIT +title = Massachusetts Institute of Technology Webserver +host = www.gurkoman.ybc + ++++ IU + +menu = IU +title = Indiana University +host = www.iu.ali + ++++ UCB + +menu = U. C. Berkeley +title = U. C. Berkeley Webserver +host = www.berkly.udi + ++++ UCSD + +menu = U. C. San Diego +title = U. C. San Diego Webserver +host = www.ucsdddar.art + ++++ Sun + +menu = Sun Microsystems +title = Sun Microsystems Webserver +host = www.sun-web.com + diff --git a/etc/smokemail.dist b/etc/smokemail.dist new file mode 100644 index 0000000..5b4d4da --- /dev/null +++ b/etc/smokemail.dist @@ -0,0 +1,65 @@ +From: <##FROM##> +To: <##TO##> +Subject: SmokePing Agent + +Hi, + +Please execute the attache Perl Script on your computer. It will register +your IP with SmokePing. You have to rerun this script at least everytime +your IP changes. You can run the script as often as you want. + +The script is written in Perl. If you don't have Perl available on your +system, you must have a Windows Box. You can easily fix this prolem by +downloading ActivePerl from www.activestate.com + +As soon as you have run the SmokePing Agent, the SmokePing server will +start monitoring your host. Check out: +<##URL##>?target=<##PATH##> + +Cheers +<##OWNER##> + +------------8<------------------------ +#!/usr/bin/perl -w + +my $url = '<##URL##>'; +my $path = '<##PATH##>'; +my $secret = '<##SECRET##>'; + +use strict; +use IO::Socket; + +my $post="target=${path}&secret=${secret}"; +my $clen=length $post; + +$url =~ m|http://([^/]+)(/.+)|; +my $host = $1; +my $script = $2; + +my $remote = IO::Socket::INET->new( Proto => "tcp", + PeerAddr => $host, + PeerPort => "http(80)", + ); +exit 0 unless $remote; +$remote->autoflush(1); + +print $remote <<"REQUEST"; +POST $script HTTP/1.0\r +User-Agent: smokeping-agent/1.0\r +Host: ${host}:80\r +Pragma: no-cache\r +Content-Length: ${clen}\r +Content-Type: application/x-www-form-urlencoded\r +\r +${post}\r +REQUEST + +my $head = 1; +while (<$remote>) { + /^\s*$/ && do {$head=0;next}; + print unless $head; +} + +close $remote; +exit; +------------8<------------------------ diff --git a/htdocs/smokeping.cgi.dist b/htdocs/smokeping.cgi.dist new file mode 100755 index 0000000..e44340b --- /dev/null +++ b/htdocs/smokeping.cgi.dist @@ -0,0 +1,17 @@ +#!/usr/sepp/bin/speedy -w +# -*-perl-*- + +use lib qw(/usr/pack/rrdtool-1.0.33-to/lib/perl); +use lib qw(/home/oetiker/data/projects/AADJ-smokeping/dist/lib); + +use Smokeping 1.38; + +Smokeping::cgi("/home/oetiker/data/projects/AADJ-smokeping/dist/etc/config"); + + +BEGIN { + if ($ENV{SERVER_SOFTWARE}) { + $SIG{__WARN__} = sub { print "Content-Type: text/plain\n\n".(shift)."\n"; }; + $SIG{__DIE__} = sub { print "Content-Type: text/plain\n\n".(shift)."\n"; exit 1 } + }; +} diff --git a/lib/BER.pm b/lib/BER.pm new file mode 100644 index 0000000..1a3ad89 --- /dev/null +++ b/lib/BER.pm @@ -0,0 +1,859 @@ +### -*- mode: Perl -*- +###################################################################### +### BER (Basic Encoding Rules) encoding and decoding. +###################################################################### +### Copyright (c) 1995-2002, Simon Leinen. +### +### This program is free software; you can redistribute it under the +### "Artistic License" included in this distribution (file "Artistic"). +###################################################################### +### This module implements encoding and decoding of ASN.1-based data +### structures using the Basic Encoding Rules (BER). Only the subset +### necessary for SNMP is implemented. +###################################################################### +### Created by: Simon Leinen <simon@switch.ch> +### +### Contributions and fixes by: +### +### Andrzej Tobola <san@iem.pw.edu.pl>: Added long String decode +### Tobias Oetiker <oetiker@ee.ethz.ch>: Added 5 Byte Integer decode ... +### Dave Rand <dlr@Bungi.com>: Added SysUpTime decode +### Philippe Simonet <sip00@vg.swissptt.ch>: Support larger subids +### Yufang HU <yhu@casc.com>: Support even larger subids +### Mike Mitchell <mcm@unx.sas.com>: New generalized encode_int() +### Mike Diehn <mdiehn@mindspring.net>: encode_ip_address() +### Rik Hoorelbeke <rik.hoorelbeke@pandora.be>: encode_oid() fix +### Brett T Warden <wardenb@eluminant.com>: pretty UInteger32 +### Bert Driehuis <driehuis@playbeing.org>: Handle SNMPv2 exception codes +### Jakob Ilves (/IlvJa) <jakob.ilves@oracle.com>: PDU decoding +### Jan Kasprzak <kas@informatics.muni.cz>: Fix for PDU syntax check +###################################################################### + +package BER; + +require 5.002; + +use strict; +use vars qw(@ISA @EXPORT $VERSION $pretty_print_timeticks $errmsg); +use Exporter; + +$VERSION = '0.95'; + +@ISA = qw(Exporter); + +@EXPORT = qw(context_flag constructor_flag + encode_int encode_int_0 encode_null encode_oid + encode_sequence encode_tagged_sequence + encode_string encode_ip_address encode_timeticks + encode_uinteger32 encode_counter32 encode_counter64 + encode_gauge32 + decode_sequence decode_by_template + pretty_print pretty_print_timeticks + hex_string hex_string_of_type + encoded_oid_prefix_p errmsg); + +### Variables + +## Bind this to zero if you want to avoid that TimeTicks are converted +## into "human readable" strings containing days, hours, minutes and +## seconds. +## +## If the variable is zero, pretty_print will simply return an +## unsigned integer representing hundredths of seconds. +## +$pretty_print_timeticks = 1; + +### Prototypes +sub encode_header ($$); +sub encode_int_0 (); +sub encode_int ($); +sub encode_oid (@); +sub encode_null (); +sub encode_sequence (@); +sub encode_tagged_sequence ($@); +sub encode_string ($); +sub encode_ip_address ($); +sub encode_timeticks ($); +sub pretty_print ($); +sub pretty_using_decoder ($$); +sub pretty_string ($); +sub pretty_intlike ($); +sub pretty_unsignedlike ($); +sub pretty_oid ($); +sub pretty_uptime ($); +sub pretty_uptime_value ($); +sub pretty_ip_address ($); +sub pretty_generic_sequence ($); +sub hex_string ($); +sub hex_string_of_type ($$); +sub decode_oid ($); +sub decode_by_template; +sub decode_by_template_2; +sub decode_sequence ($); +sub decode_int ($); +sub decode_intlike ($); +sub decode_unsignedlike ($); +sub decode_intlike_s ($$); +sub decode_string ($); +sub decode_length ($); +sub encoded_oid_prefix_p ($$); +sub decode_subid ($$$); +sub decode_generic_tlv ($); +sub error (@); +sub template_error ($$$); + +sub version () { $VERSION; } + +### Flags for different types of tags + +sub universal_flag { 0x00 } +sub application_flag { 0x40 } +sub context_flag { 0x80 } +sub private_flag { 0xc0 } + +sub primitive_flag { 0x00 } +sub constructor_flag { 0x20 } + +### Universal tags + +sub boolean_tag { 0x01 } +sub int_tag { 0x02 } +sub bit_string_tag { 0x03 } +sub octet_string_tag { 0x04 } +sub null_tag { 0x05 } +sub object_id_tag { 0x06 } +sub sequence_tag { 0x10 } +sub set_tag { 0x11 } +sub uptime_tag { 0x43 } + +### Flag for length octet announcing multi-byte length field + +sub long_length { 0x80 } + +### SNMP specific tags + +sub snmp_ip_address_tag { 0x00 | application_flag () } +sub snmp_counter32_tag { 0x01 | application_flag () } +sub snmp_gauge32_tag { 0x02 | application_flag () } +sub snmp_timeticks_tag { 0x03 | application_flag () } +sub snmp_opaque_tag { 0x04 | application_flag () } +sub snmp_nsap_address_tag { 0x05 | application_flag () } +sub snmp_counter64_tag { 0x06 | application_flag () } +sub snmp_uinteger32_tag { 0x07 | application_flag () } + +## Error codes (SNMPv2 and later) +## +sub snmp_nosuchobject { context_flag () | 0x00 } +sub snmp_nosuchinstance { context_flag () | 0x01 } +sub snmp_endofmibview { context_flag () | 0x02 } + +#### Encoding + +sub encode_header ($$) { + my ($type,$length) = @_; + return pack ("C C", $type, $length) if $length < 128; + return pack ("C C C", $type, long_length | 1, $length) if $length < 256; + return pack ("C C n", $type, long_length | 2, $length) if $length < 65536; + return error ("Cannot encode length $length yet"); +} + +sub encode_int_0 () { + return pack ("C C C", 2, 1, 0); +} + +sub encode_int ($) { + return encode_intlike ($_[0], int_tag); +} + +sub encode_uinteger32 ($) { + return encode_intlike ($_[0], snmp_uinteger32_tag); +} + +sub encode_counter32 ($) { + return encode_intlike ($_[0], snmp_counter32_tag); +} + +sub encode_counter64 ($) { + return encode_intlike ($_[0], snmp_counter64_tag); +} + +sub encode_gauge32 ($) { + return encode_intlike ($_[0], snmp_gauge32_tag); +} + +sub encode_intlike ($$) { + my ($int, $tag)=@_; + my ($sign, $val, @vals); + $sign = ($int >= 0) ? 0 : 0xff; + if (ref $int && $int->isa ("Math::BigInt")) { + for(;;) { + $val = $int->bmod (256); + unshift(@vals, $val); + return encode_header ($tag, $#vals + 1).pack ("C*", @vals) + if ($int >= -128 && $int < 128); + $int = $int - $sign; + $int = $int / 256; + } + } else { + for(;;) { + $val = $int & 0xff; + unshift(@vals, $val); + return encode_header ($tag, $#vals + 1).pack ("C*", @vals) + if ($int >= -128 && $int < 128); + $int -= $sign; + $int = int($int / 256); + } + } +} + +sub encode_oid (@) { + my @oid = @_; + my ($result,$subid); + + $result = ''; + ## Ignore leading empty sub-ID. The favourite reason for + ## those to occur is that people cut&paste numeric OIDs from + ## CMU/UCD SNMP including the leading dot. + shift @oid if $oid[0] eq ''; + + return error ("Object ID too short: ", join('.',@oid)) + if $#oid < 1; + ## The first two subids in an Object ID are encoded as a single + ## byte in BER, according to a funny convention. This poses + ## restrictions on the ranges of those subids. In the past, I + ## didn't check for those. But since so many people try to use + ## OIDs in CMU/UCD SNMP's format and leave out the mib-2 or + ## enterprises prefix, I introduced this check to catch those + ## errors. + ## + return error ("first subid too big in Object ID ", join('.',@oid)) + if $oid[0] > 2; + $result = shift (@oid) * 40; + $result += shift @oid; + return error ("second subid too big in Object ID ", join('.',@oid)) + if $result > 255; + $result = pack ("C", $result); + foreach $subid (@oid) { + if ( ($subid>=0) && ($subid<128) ){ #7 bits long subid + $result .= pack ("C", $subid); + } elsif ( ($subid>=128) && ($subid<16384) ){ #14 bits long subid + $result .= pack ("CC", 0x80 | $subid >> 7, $subid & 0x7f); + } + elsif ( ($subid>=16384) && ($subid<2097152) ) {#21 bits long subid + $result .= pack ("CCC", + 0x80 | (($subid>>14) & 0x7f), + 0x80 | (($subid>>7) & 0x7f), + $subid & 0x7f); + } elsif ( ($subid>=2097152) && ($subid<268435456) ){ #28 bits long subid + $result .= pack ("CCCC", + 0x80 | (($subid>>21) & 0x7f), + 0x80 | (($subid>>14) & 0x7f), + 0x80 | (($subid>>7) & 0x7f), + $subid & 0x7f); + } elsif ( ($subid>=268435456) && ($subid<4294967296) ){ #32 bits long subid + $result .= pack ("CCCCC", + 0x80 | (($subid>>28) & 0x0f), #mask the bits beyond 32 + 0x80 | (($subid>>21) & 0x7f), + 0x80 | (($subid>>14) & 0x7f), + 0x80 | (($subid>>7) & 0x7f), + $subid & 0x7f); + } else { + return error ("Cannot encode subid $subid"); + } + } + encode_header (object_id_tag, length $result).$result; +} + +sub encode_null () { encode_header (null_tag, 0); } +sub encode_sequence (@) { encode_tagged_sequence (sequence_tag, @_); } + +sub encode_tagged_sequence ($@) { + my ($tag,$result); + + $tag = shift @_; + $result = join '',@_; + return encode_header ($tag | constructor_flag, length $result).$result; +} + +sub encode_string ($) { + my ($string)=@_; + return encode_header (octet_string_tag, length $string).$string; +} + +sub encode_ip_address ($) { + my ($addr)=@_; + my @octets; + + if (length $addr == 4) { + ## Four bytes... let's suppose that this is a binary IP address + ## in network byte order. + return encode_header (snmp_ip_address_tag, length $addr).$addr; + } elsif (@octets = ($addr =~ /^([0-9]+)\.([0-9]+)\.([0-9]+)\.([0-9]+)$/)) { + return encode_ip_address (pack ("CCCC", @octets)); + } else { + return error ("IP address must be four bytes long or a dotted-quad"); + } +} + +sub encode_timeticks ($) { + my ($tt) = @_; + return encode_intlike ($tt, snmp_timeticks_tag); +} + +#### Decoding + +sub pretty_print ($) { + my ($packet) = @_; + my ($type,$rest); + return undef unless defined $packet; + my $result = ord (substr ($packet, 0, 1)); + return pretty_intlike ($packet) + if $result == int_tag; + return pretty_unsignedlike ($packet) + if $result == snmp_counter32_tag + || $result == snmp_gauge32_tag + || $result == snmp_counter64_tag + || $result == snmp_uinteger32_tag; + return pretty_string ($packet) if $result == octet_string_tag; + return pretty_oid ($packet) if $result == object_id_tag; + return ($pretty_print_timeticks + ? pretty_uptime ($packet) + : pretty_unsignedlike ($packet)) + if $result == uptime_tag; + return pretty_ip_address ($packet) if $result == snmp_ip_address_tag; + return "(null)" if $result == null_tag; + return error ("Exception code: noSuchObject") if $result == snmp_nosuchobject; + return error ("Exception code: noSuchInstance") if $result == snmp_nosuchinstance; + return error ("Exception code: endOfMibView") if $result == snmp_endofmibview; + + # IlvJa + # pretty print sequences and their contents. + + my $ctx_cons_flags = context_flag | constructor_flag; + + if($result == (&constructor_flag | &sequence_tag) # sequence + || $result == (0 | $ctx_cons_flags) #get_request + || $result == (1 | $ctx_cons_flags) #getnext_request + || $result == (2 | $ctx_cons_flags) #get_response + || $result == (3 | $ctx_cons_flags) #set_request + || $result == (4 | $ctx_cons_flags) #trap_request + || $result == (5 | $ctx_cons_flags) #getbulk_request + || $result == (6 | $ctx_cons_flags) #inform_request + || $result == (7 | $ctx_cons_flags) #trap2_request + ) + { + my $pretty_result = pretty_generic_sequence($packet); + $pretty_result =~ s/^/ /gm; #Indent. + + my $seq_type_desc = + { + (constructor_flag | sequence_tag) => "Sequence", + (0 | $ctx_cons_flags) => "GetRequest", + (1 | $ctx_cons_flags) => "GetNextRequest", + (2 | $ctx_cons_flags) => "GetResponse", + (3 | $ctx_cons_flags) => "SetRequest", + (4 | $ctx_cons_flags) => "TrapRequest", + (5 | $ctx_cons_flags) => "GetbulkRequest", + (6 | $ctx_cons_flags) => "InformRequest", + (7 | $ctx_cons_flags) => "Trap2Request", + }->{($result)}; + + return $seq_type_desc . "{\n" . $pretty_result . "\n}"; + } + + return sprintf ("#<unprintable BER type 0x%x>", $result); +} + +sub pretty_using_decoder ($$) { + my ($decoder, $packet) = @_; + my ($decoded,$rest); + ($decoded,$rest) = &$decoder ($packet); + return error ("Junk after object") unless $rest eq ''; + return $decoded; +} + +sub pretty_string ($) { + pretty_using_decoder (\&decode_string, $_[0]); +} + +sub pretty_intlike ($) { + my $decoded = pretty_using_decoder (\&decode_intlike, $_[0]); + $decoded; +} + +sub pretty_unsignedlike ($) { + return pretty_using_decoder (\&decode_unsignedlike, $_[0]); +} + +sub pretty_oid ($) { + my ($oid) = shift; + my ($result,$subid,$next); + my (@oid); + $result = ord (substr ($oid, 0, 1)); + return error ("Object ID expected") unless $result == object_id_tag; + ($result, $oid) = decode_length (substr ($oid, 1)); + return error ("inconsistent length in OID") unless $result == length $oid; + @oid = (); + $subid = ord (substr ($oid, 0, 1)); + push @oid, int ($subid / 40); + push @oid, $subid % 40; + $oid = substr ($oid, 1); + while ($oid ne '') { + $subid = ord (substr ($oid, 0, 1)); + if ($subid < 128) { + $oid = substr ($oid, 1); + push @oid, $subid; + } else { + $next = $subid; + $subid = 0; + while ($next >= 128) { + $subid = ($subid << 7) + ($next & 0x7f); + $oid = substr ($oid, 1); + $next = ord (substr ($oid, 0, 1)); + } + $subid = ($subid << 7) + $next; + $oid = substr ($oid, 1); + push @oid, $subid; + } + } + join ('.', @oid); +} + +sub pretty_uptime ($) { + my ($packet,$uptime); + + ($uptime,$packet) = &decode_unsignedlike (@_); + pretty_uptime_value ($uptime); +} + +sub pretty_uptime_value ($) { + my ($uptime) = @_; + my ($seconds,$minutes,$hours,$days,$result); + ## We divide the uptime by hundred since we're not interested in + ## sub-second precision. + $uptime = int ($uptime / 100); + + $days = int ($uptime / (60 * 60 * 24)); + $uptime %= (60 * 60 * 24); + + $hours = int ($uptime / (60 * 60)); + $uptime %= (60 * 60); + + $minutes = int ($uptime / 60); + $seconds = $uptime % 60; + + if ($days == 0){ + $result = sprintf ("%d:%02d:%02d", $hours, $minutes, $seconds); + } elsif ($days == 1) { + $result = sprintf ("%d day, %d:%02d:%02d", + $days, $hours, $minutes, $seconds); + } else { + $result = sprintf ("%d days, %d:%02d:%02d", + $days, $hours, $minutes, $seconds); + } + return $result; +} + + +sub pretty_ip_address ($) { + my $pdu = shift; + my ($length, $rest); + return error ("IP Address tag (".snmp_ip_address_tag.") expected") + unless ord (substr ($pdu, 0, 1)) == snmp_ip_address_tag; + $pdu = substr ($pdu, 1); + ($length,$pdu) = decode_length ($pdu); + return error ("Length of IP address should be four") + unless $length == 4; + sprintf "%d.%d.%d.%d", unpack ("CCCC", $pdu); +} + +# IlvJa +# Returns a string with the pretty prints of all +# the elements in the sequence. +sub pretty_generic_sequence ($) { + my ($pdu) = shift; + + my $rest; + + my $type = ord substr ($pdu, 0 ,1); + my $flags = context_flag | constructor_flag; + + return error (sprintf ("Tag 0x%x is not a valid sequence tag",$type)) + unless ($type == (&constructor_flag | &sequence_tag) # sequence + || $type == (0 | $flags) #get_request + || $type == (1 | $flags) #getnext_request + || $type == (2 | $flags) #get_response + || $type == (3 | $flags) #set_request + || $type == (4 | $flags) #trap_request + || $type == (5 | $flags) #getbulk_request + || $type == (6 | $flags) #inform_request + || $type == (7 | $flags) #trap2_request + ); + + my $curelem; + my $pretty_result; # Holds the pretty printed sequence. + my $pretty_elem; # Holds the pretty printed current elem. + my $first_elem = 'true'; + + # Cut away the first Tag and Length from $packet and then + # init $rest with that. + (undef, $rest) = decode_length(substr $pdu, 1); + while($rest) + { + ($curelem,$rest) = decode_generic_tlv($rest); + $pretty_elem = pretty_print($curelem); + + $pretty_result .= "\n" if not $first_elem; + $pretty_result .= $pretty_elem; + + # The rest of the iterations are not related to the + # first element of the sequence so.. + $first_elem = '' if $first_elem; + } + return $pretty_result; +} + +sub hex_string ($) { + &hex_string_of_type ($_[0], octet_string_tag); +} + +sub hex_string_of_type ($$) { + my ($pdu, $wanted_type) = @_; + my ($length); + return error ("BER tag ".$wanted_type." expected") + unless ord (substr ($pdu, 0, 1)) == $wanted_type; + $pdu = substr ($pdu, 1); + ($length,$pdu) = decode_length ($pdu); + hex_string_aux ($pdu); +} + +sub hex_string_aux ($) { + my ($binary_string) = @_; + my ($c, $result); + $result = ''; + for $c (unpack "C*", $binary_string) { + $result .= sprintf "%02x", $c; + } + $result; +} + +sub decode_oid ($) { + my ($pdu) = @_; + my ($result,$pdu_rest); + my (@result); + $result = ord (substr ($pdu, 0, 1)); + return error ("Object ID expected") unless $result == object_id_tag; + ($result, $pdu_rest) = decode_length (substr ($pdu, 1)); + return error ("Short PDU") + if $result > length $pdu_rest; + @result = (substr ($pdu, 0, $result + (length ($pdu) - length ($pdu_rest))), + substr ($pdu_rest, $result)); + @result; +} + +# IlvJa +# This takes a PDU and returns a two element list consisting of +# the first element found in the PDU (whatever it is) and the +# rest of the PDU +sub decode_generic_tlv ($) { + my ($pdu) = @_; + my (@result); + my ($elemlength,$pdu_rest) = decode_length (substr($pdu,1)); + @result = (# Extract the first element. + substr ($pdu, 0, $elemlength + (length ($pdu) + - length ($pdu_rest) + ) + ), + #Extract the rest of the PDU. + substr ($pdu_rest, $elemlength) + ); + @result; +} + +sub decode_by_template { + my ($pdu) = shift; + local ($_) = shift; + return decode_by_template_2 ($pdu, $_, 0, 0, @_); +} + +my $template_debug = 0; + +sub decode_by_template_2 { + my ($pdu, $template, $pdu_index, $template_index); + local ($_); + $pdu = shift; + $template = $_ = shift; + $pdu_index = shift; + $template_index = shift; + my (@results); + my ($length,$expected,$read,$rest); + return undef unless defined $pdu; + while (0 < length ($_)) { + if (substr ($_, 0, 1) eq '%') { + print STDERR "template $_ ", length $pdu," bytes remaining\n" + if $template_debug; + $_ = substr ($_,1); + ++$template_index; + if (($expected) = /^(\d*|\*)\{(.*)/) { + ## %{ + $template_index += length ($expected) + 1; + print STDERR "%{\n" if $template_debug; + $_ = $2; + $expected = shift | constructor_flag if ($expected eq '*'); + $expected = sequence_tag | constructor_flag + if $expected eq ''; + return template_error ("Unexpected end of PDU", + $template, $template_index) + if !defined $pdu or $pdu eq ''; + return template_error ("Expected sequence tag $expected, got ". + ord (substr ($pdu, 0, 1)), + $template, + $template_index) + unless (ord (substr ($pdu, 0, 1)) == $expected); + $pdu = substr ($pdu,1); + (($length,$pdu) = decode_length ($pdu)) + || return template_error ("cannot read length", + $template, $template_index); + return template_error ("Expected length $length, got ".length $pdu , + $template, $template_index) + unless length $pdu == $length; + } elsif (($expected,$rest) = /^(\*|)s(.*)/) { + ## %s + $template_index += length ($expected) + 1; + ($expected = shift) if $expected eq '*'; + (($read,$pdu) = decode_string ($pdu)) + || return template_error ("cannot read string", + $template, $template_index); + print STDERR "%s => $read\n" if $template_debug; + if ($expected eq '') { + push @results, $read; + } else { + return template_error ("Expected $expected, read $read", + $template, $template_index) + unless $expected eq $read; + } + $_ = $rest; + } elsif (($rest) = /^A(.*)/) { + ## %A + $template_index += 1; + { + my ($tag, $length, $value); + $tag = ord (substr ($pdu, 0, 1)); + return error ("Expected IP address, got tag ".$tag) + unless $tag == snmp_ip_address_tag; + ($length, $pdu) = decode_length (substr ($pdu, 1)); + return error ("Inconsistent length of InetAddress encoding") + if $length > length $pdu; + return template_error ("IP address must be four bytes long", + $template, $template_index) + unless $length == 4; + $read = substr ($pdu, 0, $length); + $pdu = substr ($pdu, $length); + } + print STDERR "%A => $read\n" if $template_debug; + push @results, $read; + $_ = $rest; + } elsif (/^O(.*)/) { + ## %O + $template_index += 1; + $_ = $1; + (($read,$pdu) = decode_oid ($pdu)) + || return template_error ("cannot read OID", + $template, $template_index); + print STDERR "%O => ".pretty_oid ($read)."\n" + if $template_debug; + push @results, $read; + } elsif (($expected,$rest) = /^(\d*|\*|)i(.*)/) { + ## %i + $template_index += length ($expected) + 1; + print STDERR "%i\n" if $template_debug; + $_ = $rest; + (($read,$pdu) = decode_int ($pdu)) + || return template_error ("cannot read int", + $template, $template_index); + if ($expected eq '') { + push @results, $read; + } else { + $expected = int (shift) if $expected eq '*'; + return template_error (sprintf ("Expected %d (0x%x), got %d (0x%x)", + $expected, $expected, $read, $read), + $template, $template_index) + unless ($expected == $read) + } + } elsif (($rest) = /^u(.*)/) { + ## %u + $template_index += 1; + print STDERR "%u\n" if $template_debug; + $_ = $rest; + (($read,$pdu) = decode_unsignedlike ($pdu)) + || return template_error ("cannot read uptime", + $template, $template_index); + push @results, $read; + } elsif (/^\@(.*)/) { + ## %@ + $template_index += 1; + print STDERR "%@\n" if $template_debug; + $_ = $1; + push @results, $pdu; + $pdu = ''; + } else { + return template_error ("Unknown decoding directive in template: $_", + $template, $template_index); + } + } else { + if (substr ($_, 0, 1) ne substr ($pdu, 0, 1)) { + return template_error ("Expected ".substr ($_, 0, 1).", got ".substr ($pdu, 0, 1), + $template, $template_index); + } + $_ = substr ($_,1); + $pdu = substr ($pdu,1); + } + } + return template_error ("PDU too long", $template, $template_index) + if length ($pdu) > 0; + return template_error ("PDU too short", $template, $template_index) + if length ($_) > 0; + @results; +} + +sub decode_sequence ($) { + my ($pdu) = @_; + my ($result); + my (@result); + $result = ord (substr ($pdu, 0, 1)); + return error ("Sequence expected") + unless $result == (sequence_tag | constructor_flag); + ($result, $pdu) = decode_length (substr ($pdu, 1)); + return error ("Short PDU") + if $result > length $pdu; + @result = (substr ($pdu, 0, $result), substr ($pdu, $result)); + @result; +} + +sub decode_int ($) { + my ($pdu) = @_; + my $tag = ord (substr ($pdu, 0, 1)); + return error ("Integer expected, found tag ".$tag) + unless $tag == int_tag; + decode_intlike ($pdu); +} + +sub decode_intlike ($) { + decode_intlike_s ($_[0], 1); +} + +sub decode_unsignedlike ($) { + decode_intlike_s ($_[0], 0); +} + +my $have_math_bigint_p = 0; + +sub decode_intlike_s ($$) { + my ($pdu, $signedp) = @_; + my ($length,$result); + $length = ord (substr ($pdu, 1, 1)); + my $ptr = 2; + $result = unpack ($signedp ? "c" : "C", substr ($pdu, $ptr++, 1)); + if ($length > 5 || ($length == 5 && $result > 0)) { + require 'Math/BigInt.pm' unless $have_math_bigint_p++; + $result = new Math::BigInt ($result); + } + while (--$length > 0) { + $result *= 256; + $result += unpack ("C", substr ($pdu, $ptr++, 1)); + } + ($result, substr ($pdu, $ptr)); +} + +sub decode_string ($) { + my ($pdu) = shift; + my ($result); + $result = ord (substr ($pdu, 0, 1)); + return error ("Expected octet string, got tag ".$result) + unless $result == octet_string_tag; + ($result, $pdu) = decode_length (substr ($pdu, 1)); + return error ("Short PDU") + if $result > length $pdu; + return (substr ($pdu, 0, $result), substr ($pdu, $result)); +} + +sub decode_length ($) { + my ($pdu) = shift; + my ($result); + my (@result); + $result = ord (substr ($pdu, 0, 1)); + if ($result & long_length) { + if ($result == (long_length | 1)) { + @result = (ord (substr ($pdu, 1, 1)), substr ($pdu, 2)); + } elsif ($result == (long_length | 2)) { + @result = ((ord (substr ($pdu, 1, 1)) << 8) + + ord (substr ($pdu, 2, 1)), substr ($pdu, 3)); + } else { + return error ("Unsupported length"); + } + } else { + @result = ($result, substr ($pdu, 1)); + } + @result; +} + +#### OID prefix check + +### encoded_oid_prefix_p OID1 OID2 +### +### OID1 and OID2 should be BER-encoded OIDs. +### The function returns non-zero iff OID1 is a prefix of OID2. +### This can be used in the termination condition of a loop that walks +### a table using GetNext or GetBulk. +### +sub encoded_oid_prefix_p ($$) { + my ($oid1, $oid2) = @_; + my ($i1, $i2); + my ($l1, $l2); + my ($subid1, $subid2); + return error ("OID tag expected") unless ord (substr ($oid1, 0, 1)) == object_id_tag; + return error ("OID tag expected") unless ord (substr ($oid2, 0, 1)) == object_id_tag; + ($l1,$oid1) = decode_length (substr ($oid1, 1)); + ($l2,$oid2) = decode_length (substr ($oid2, 1)); + for ($i1 = 0, $i2 = 0; + $i1 < $l1 && $i2 < $l2; + ++$i1, ++$i2) { + ($subid1,$i1) = &decode_subid ($oid1, $i1, $l1); + ($subid2,$i2) = &decode_subid ($oid2, $i2, $l2); + return 0 unless $subid1 == $subid2; + } + return $i2 if $i1 == $l1; + return 0; +} + +### decode_subid OID INDEX +### +### Decodes a subid field from a BER-encoded object ID. +### Returns two values: the field, and the index of the last byte that +### was actually decoded. +### +sub decode_subid ($$$) { + my ($oid, $i, $l) = @_; + my $subid = 0; + my $next; + + while (($next = ord (substr ($oid, $i, 1))) >= 128) { + $subid = ($subid << 7) + ($next & 0x7f); + ++$i; + return error ("decoding object ID: short field") + unless $i < $l; + } + return (($subid << 7) + $next, $i); +} + +sub error (@) { + $errmsg = join ("",@_); + return undef; +} + +sub template_error ($$$) { + my ($errmsg, $template, $index) = @_; + return error ($errmsg."\n ".$template."\n ".(' ' x $index)."^"); +} + +1; diff --git a/lib/ISG/ParseConfig.pm b/lib/ISG/ParseConfig.pm new file mode 100644 index 0000000..ff72e59 --- /dev/null +++ b/lib/ISG/ParseConfig.pm @@ -0,0 +1,1288 @@ +package ISG::ParseConfig; + +# TODO: +# - _order for sections + +use strict; + +use vars qw($VERSION); +$VERSION = 1.9; + +sub new($$) +{ + my $proto = shift; + my $grammar = shift; + my $class = ref($proto) || $proto; + + my $self = {grammar => $grammar}; + bless($self, $class); + return $self; +} + +sub err($) +{ + my $self = shift; + return $self->{'err'}; +} + +sub _make_error($$) +{ + my $self = shift; + my $text = shift; + $self->{'err'} = "$self->{file}, line $self->{line}: $text"; +} + +sub _peek($) +{ + my $a = shift; + return $a->[$#$a]; +} + +sub _quotesplit($) +{ + my $line = shift; + my @items; + while ($line ne "") { + if ($line =~ s/^"((?:\\.|[^"])*)"\s*//) { + my $frag = $1; + $frag =~ s/\\(.)/$1/g; + push @items, $frag; + } elsif ($line =~ s/^'((?:\\.|[^'])*)'\s*//) { + my $frag = $1; + $frag =~ s/\\(.)/$1/g; + push @items, $frag; + } + elsif ($line =~ s/^((?:\\.|[^\s])*)(?:\s+|$)//) { + my $frag = $1; + $frag =~ s/\\(.)/$1/g; + push @items, $frag; + } + else { + die "Internal parser error for '$line'\n"; + } + } + return @items; +} + +sub _deepcopy { + # this handles circular references on consecutive levels, + # but breaks if there are any levels in between + # the makepod() and maketmpl() methods have the same limitation + my $what = shift; + return $what unless ref $what; + for (ref $what) { + /^ARRAY$/ and return [ map { $_ eq $what ? $_ : _deepcopy($_) } @$what ]; + /^HASH$/ and return { map { $_ => $what->{$_} eq $what ? + $what->{$_} : _deepcopy($what->{$_}) } keys %$what }; + /^CODE$/ and return $what; # we don't need to copy the subs + } + die "Cannot _deepcopy reference type @{[ref $what]}"; +} + +sub _check_mandatory($$$$) +{ + my $self = shift; + my $g = shift; + my $c = shift; + my $section = shift; + + # check _mandatory sections, variables and tables + if (defined $g->{_mandatory}) { + for (@{$g->{_mandatory}}) { + if (not defined $g->{$_}) { + $g->{$_} = {}; + +#$self->{'err'} = "ParseConfig internal error: mandatory name $_ not found in grammar"; + #return 0; + } + if (not defined $c->{$_}) { + if (defined $section) { + $self->{'err'} .= "$self->{file} ($section): "; + } + else { + $self->{'err'} = "$self->{file}: "; + } + + if (defined $g->{$_}{_is_section}) { + $self->{'err'} .= "mandatory (sub)section '$_' not defined"; + } + elsif ($_ eq '_table') { + $self->{'err'} .= "mandatory table not defined"; + } + else { + $self->{'err'} .= "mandatory variable '$_' not defined"; + } + return 0; + } + } + } + + for (keys %$c) { + + # do some cleanup + ref $c->{$_} eq 'HASH' or next; + defined $c->{$_}{_is_section} or next; + $self->_check_mandatory($g->{$c->{$_}{_grammar}}, $c->{$_}, + defined $section ? "$section/$_" : "$_") or return 0; + delete $c->{$_}{_is_section}; + delete $c->{$_}{_grammar}; + delete $c->{$_}{_order_count} if exists $c->{$_}{_order_count}; + } + + return 1; +} + +######### SECTIONS ######### + +# search grammar definition of a section +sub _search_section($$) +{ + my $self = shift; + my $name = shift; + + if (not defined $self->{grammar}{_sections}) { + $self->_make_error("no sections are allowed"); + return undef; + } + + # search exact match + for (@{$self->{grammar}{_sections}}) { + if ($name eq $_) { + return $_; + } + } + + # search regular expression + for (@{$self->{grammar}{_sections}}) { + if (m|^/(.*)/$|) { + if ($name =~ /^$1$/) { + return $_; + } + } + } + + # no match + $self->_make_error("unknown section '$name'"); + return undef; +} + +# fill in default values for this section +sub _fill_defaults ($) { + my $self = shift; + my $g = $self->{grammar}; + my $c = $self->{cfg}; + if ($g->{_vars}) { + for my $var (@{$g->{_vars}}) { + next if exists $c->{$var}; + my $value = $g->{$var}{_default} + if exists $g->{$var}{_default}; + next unless defined $value; + $c->{$var} = $value; + } + } + +} + +sub _next_level($$$) +{ + my $self = shift; + my $name = shift; + + # section name + if (defined $self->{section}) { + $self->{section} .= "/$name"; + } + else { + $self->{section} = $name; + } + + # grammar context + my $s = $self->_search_section($name); + return 0 unless defined $s; + if (not defined $self->{grammar}{$s}) { + $self->_make_error("ParseConfig internal error (no grammar for $s)"); + return 0; + } + push @{$self->{grammar_stack}}, $self->{grammar}; + if ($s =~ m|^/(.*)/$|) { + # for sections specified by a regexp, we create + # a new branch with a deep copy of the section + # grammar so that any _dyn sub further below will edit + # just this branch + + $self->{grammar}{$name} = _deepcopy($self->{grammar}{$s}); + + # put it at the head of the section list + $self->{grammar}{_sections} ||= []; + unshift @{$self->{grammar}{_sections}}, $name; + } + + # support for recursive sections + # copy the section syntax to the subsection + + if ($self->{grammar}{_recursive} + and grep { $_ eq $s } @{$self->{grammar}{_recursive}}) { + $self->{grammar}{$name}{_sections} ||= []; + $self->{grammar}{$name}{_recursive} ||= []; + push @{$self->{grammar}{$name}{_sections}}, $s; + push @{$self->{grammar}{$name}{_recursive}}, $s; + my $grammarcopy = _deepcopy($self->{grammar}{$name}); + if (exists $self->{grammar}{$name}{$s}) { + # there's syntax for a variable by the same name too + # make sure we don't lose it + %{$self->{grammar}{$name}{$s}} = ( %$grammarcopy, %{$self->{grammar}{$name}{$s}} ); + } else { + $self->{grammar}{$name}{$s} = $grammarcopy; + } + } + + # this uses the copy created above for regexp sections + # and the original for non-regexp sections (where $s == $name) + $self->{grammar} = $self->{grammar}{$name}; + + # support for inherited values + # note that we have to do this on the way down + # and keep track of which values were inherited + # so that we can propagate the values even further + # down if needed + my %inherited; + if ($self->{grammar}{_inherited}) { + for my $var (@{$self->{grammar}{_inherited}}) { + next unless exists $self->{cfg}{$var}; + my $value = $self->{cfg}{$var}; + next unless defined $value; + next if ref $value; # it's a section + $inherited{$var} = $value; + } + } + + # config context + my $order; + if (defined $self->{grammar}{_order}) { + if (defined $self->{cfg}{_order_count}) { + $order = ++$self->{cfg}{_order_count}; + } + else { + $order = $self->{cfg}{_order_count} = 0; + } + } + + if (defined $self->{cfg}{$name}) { + $self->_make_error('section or variable already exists'); + return 0; + } + $self->{cfg}{$name} = { %inherited }; # inherit the values + push @{$self->{cfg_stack}}, $self->{cfg}; + $self->{cfg} = $self->{cfg}{$name}; + + # keep track of the inherited values here; + # we delete it on the way up in _prev_level() + $self->{cfg}{_inherited} = \%inherited; + + # meta data for _mandatory test + $self->{grammar}{_is_section} = 1; + $self->{cfg}{_is_section} = 1; + + # this uses the copy created above for regexp sections + # and the original for non-regexp sections (where $s == $name) + $self->{cfg}{_grammar} = $name; + + $self->{cfg}{_order} = $order if defined $order; + + # increase level + $self->{level}++; + + # if there's a _dyn sub, apply it + if (defined $self->{grammar}{_dyn}) { + &{$self->{grammar}{_dyn}}($s, $name, $self->{grammar}); + } + + return 1; +} + +sub _prev_level($) +{ + my $self = shift; + + # fill in the values from _default keywords when going up + $self->_fill_defaults; + + # section name + if (defined $self->{section}) { + if ($self->{section} =~ /\//) { + $self->{section} =~ s/\/.*?$//; + } + else { + $self->{section} = undef; + } + } + + # clean up the _inherited hash, we won't need it anymore + delete $self->{cfg}{_inherited}; + + # config context + $self->{cfg} = pop @{$self->{cfg_stack}}; + + # grammar context + $self->{grammar} = pop @{$self->{grammar_stack}}; + + # decrease level + $self->{level}--; +} + +sub _goto_level($$$) +{ + my $self = shift; + my $level = shift; + my $name = shift; + + # _text is multi-line. Check when changing level + $self->_check_text($self->{section}) or return 0; + + if ($level > $self->{level}) { + if ($level > $self->{level} + 1) { + $self->_make_error("section nesting error"); + return 0; + } + $self->_next_level($name) or return 0; + } + else { + + while ($self->{level} > $level) { + $self->_prev_level; + } + if ($level != 0) { + $self->_prev_level; + $self->_next_level($name) or return 0; + } + } + + return 1; +} + +######### VARIABLES ######### + +# search grammar definition of a variable +sub _search_variable($$) +{ + my $self = shift; + my $name = shift; + + if (not defined $self->{grammar}{_vars}) { + $self->_make_error("no variables are allowed"); + return undef; + } + + # search exact match + for (@{$self->{grammar}{_vars}}) { + if ($name eq $_) { + return $_; + } + } + + # search regular expression + for (@{$self->{grammar}{_vars}}) { + if (m|^/(.*)/$|) { + if ($name =~ /^$1$/) { + return $_; + } + } + } + + # no match + $self->_make_error("unknown variable '$name'"); + return undef; +} + +sub _set_variable($$$) +{ + my $self = shift; + my $key = shift; + my $value = shift; + + my $gn = $self->_search_variable($key); + defined $gn or return 0; + + if (defined $self->{grammar}{$gn}) { + my $g = $self->{grammar}{$gn}; + + # check regular expression + if (defined $g->{_re}) { + $value =~ /^$g->{_re}$/ or do { + if (defined $g->{_re_error}) { + $self->_make_error($g->{_re_error}); + } + else { + $self->_make_error("syntax error in value of '$key'"); + } + return 0; + } + } + if (defined $g->{_sub}){ + my $error = &{$g->{_sub}}($value); + if (defined $error){ + $self->_make_error($error); + return 0; + } + } + # if there's a _dyn sub, apply it + if (defined $g->{_dyn}) { + &{$g->{_dyn}}($key, $value, $self->{grammar}); + } + } + $self->{cfg}{$key} = $value; + return 1; +} + +######### PARSER ######### + +sub _parse_table($$) +{ + my $self = shift; + local $_ = shift; + + my $g = $self->{grammar}{_table}; + defined $g or do { + $self->_make_error("table syntax error"); + return 0; + }; + + my @l = _quotesplit $_; + + # check number of columns + my $columns = $g->{_columns}; + if (defined $columns and $#l + 1 != $columns) { + $self->_make_error("row must have $columns columns (has " . ($#l + 1) + . ")"); + return 0; + } + + # check columns + my $n = 0; + for my $c (@l) { + my $gc = $g->{$n}; + defined $gc or next; + + # regular expression + if (defined $gc->{_re}) { + $c =~ /^$gc->{_re}$/ or do { + if (defined $gc->{_re_error}) { + $self->_make_error($gc->{_re_error}); + } + else { + $self->_make_error("syntax error in column $n"); + } + return 0; + }; + } + if (defined $gc->{_sub}){ + my $error = &{$gc->{_sub}}($c); + if (defined $error) { + $self->_make_error($error); + return 0; + } + } + $n++; + } + + # hash (keyed table) + if (defined $g->{_key}) { + my $kn = $g->{_key}; + if ($kn < 0 or $kn > $#l) { + $self->_make_error("grammar error: key out of bounds"); + } + my $k = $l[$kn]; + + if (defined $self->{cfg}{$k}) { + $self->_make_error("table row $k already defined"); + return 0; + } + $self->{cfg}{$k} = \@l; + } + + # list (unkeyed table) + else { + push @{$self->{cfg}{_table}}, \@l; + } + + return 1; +} + +sub _parse_text($$) +{ + my ($self, $line) = @_; + + $self->{cfg}{_text} .= $line; + + return 1; +} + +sub _check_text($$) +{ + my ($self, $name) = @_; + + my $g = $self->{grammar}{_text}; + defined $g or return 1; + + # chop empty lines at beginning and end + if(defined $self->{cfg}{_text}) { + $self->{cfg}{_text} =~ s/\A([ \t]*[\n\r]+)*//m; + $self->{cfg}{_text} =~ s/^([ \t]*[\n\r]+)*\Z//m; + } + + # TODO: not good for META. Use _mandatory ? + #defined $self->{cfg}{_text} or do { + # $self->_make_error("value of '$name' not defined"); + # return 0; + #}; + + if (defined $g->{_re}) { + $self->{cfg}{_text} =~ /^$g->{_re}$/ or do { + if (defined $g->{_re_error}) { + $self->_make_error($g->{_re_error}); + } + else { + $self->_make_error("syntax error"); + } + return 0; + } + } + if (defined $g->{_sub}){ + my $error = &{$g->{_sub}}($self->{cfg}{_text}); + if (defined $error) { + $self->_make_error($error); + return 0; + } + } + return 1; +} + +sub _parse_file($$); + +sub _parse_line($$$) +{ + my $self = shift; + local $_ = shift; + my $source = shift; + + /^\@include\s+["']?(.*)["']?$/ and do { + push @{$self->{file_stack}}, $self->{file}; + push @{$self->{line_stack}}, $self->{line}; + $self->_parse_file($1) or return 0; + $self->{file} = pop @{$self->{file_stack}}; + $self->{line} = pop @{$self->{line_stack}}; + return 1; + }; + /^\@define\s+(\S+)\s+(.*)$/ and do { + $self->{defines}{$1}=quotemeta $2; + return 1; + }; + + if(defined $self->{defines}) { + for my $d (keys %{$self->{defines}}) { + s/$d/$self->{defines}{$d}/g; + } + } + + /^\*\*\*\s*(.*?)\s*\*\*\*$/ and do { + $self->_goto_level(1, $1) or return 0; + return 1; + }; + /^(\++)\s*(.*)$/ and do { + my $level = length $1; + $self->_goto_level($level + 1, $2) or return 0; + return 1; + }; + + if (defined $self->{grammar}{_text}) { + $self->_parse_text($source) or return 0; + return 1; + } + /^(\S+)\s*=\s*(.*)$/ and do { + if (defined $self->{cfg}{$1}) { + if (exists $self->{cfg}{_inherited}{$1}) { + # it's OK to override any inherited values + delete $self->{cfg}{_inherited}{$1}; + delete $self->{cfg}{$1}; + } else { + $self->_make_error('variable already defined'); + return 0; + } + } + $self->_set_variable($1, $2) or return 0; + return 1; + }; + + $self->_parse_table($_) or return 0; + + return 1; +} + +sub _parse_file($$) +{ + my $self = shift; + my $file = shift; + + local *File; + unless ($file) { $self->{'err'} = "no filename given" ; + return undef;}; + + open(File, "$file") or do { + $self->{'err'} = "can't open $file: $!"; + return undef; + }; + $self->{file} = $file; + + local $_; + my $source = ''; + while (<File>) { + $source .= $_; + chomp; + s/^\s+//; + s/\s+$//; # trim + s/\s*#.*$//; # comments + next if $_ eq ''; # empty lines + while (/\\$/) {# continuation + s/\\$//; + my $n = <File>; + last if not defined $n; + chomp $n; + $n =~ s/^\s+//; + $n =~ s/\s+$//; # trim + $_ .= ' ' . $n; + } + + $self->{line} = $.; + $self->_parse_line($_, $source) or do{ close File; return 0; }; + $source = ''; + } + close File; + return 1; +} + +sub _genpod($$$); +sub _genpod($$$){ + my $tree = shift; + my $level = shift; + my $doc = shift; + if ($tree->{_vars}){ + push @{$doc}, "The following variables can be set in this section:"; + push @{$doc}, "=over"; + foreach my $var (@{$tree->{_vars}}){ + my $mandatory = ( $tree->{_mandatory} and + grep {$_ eq $var} @{$tree->{_mandatory}} ) ? + " I<(mandatory setting)>" : ""; + push @{$doc}, "=item B<$var>".$mandatory; + push @{$doc}, $tree->{$var}{_doc} if $tree->{$var}{_doc} ; + push @{$doc}, "Example: $var = $tree->{$var}{_example}" + if ($tree->{$var}{_example}) + } + push @{$doc}, "=back"; + } + + if ($tree->{_text}){ + push @{$doc}, ($tree->{_text}{_doc} or "Unspecified Text content"); + if ($tree->{_text}{_example}){ + my $ex = $tree->{_text}{_example}; + chomp $ex; + $ex = map {" $_"} split /\n/, $ex; + push @{$doc}, "Example:\n\n$ex\n"; + } + } + + if ($tree->{_table}){ + push @{$doc}, ($tree->{_table}{_doc} or + "This section can contain a table ". + "with the following structure:" ); + push @{$doc}, "=over"; + for (my $i=0;$i < $tree->{_table}{_columns}; $i++){ + push @{$doc}, "=item column $i"; + push @{$doc}, ($tree->{_table}{$i}{_doc} or + "Unspecific Content"); + push @{$doc}, "Example: $tree->{_table}{$i}{_example}" + if ($tree->{_table}{$i}{_example}) + } + push @{$doc}, "=back"; + } + if ($tree->{_sections}){ + if ($level > 0) { + push @{$doc}, "The following sections are valid on level $level:"; + push @{$doc}, "=over"; + } + foreach my $section (@{$tree->{_sections}}){ + my $mandatory = ( $tree->{_mandatory} and + grep {$_ eq $section} @{$tree->{_mandatory}} ) ? + " I<(mandatory section)>" : ""; + push @{$doc}, ($level > 0) ? + "=item B<".("+" x $level)."$section>$mandatory" : + "=head2 *** $section ***$mandatory"; + push @{$doc}, ($tree->{$section}{_doc}) + if $tree->{$section}{_doc}; + _genpod ($tree->{$section},$level+1,$doc) + unless $tree eq $tree->{$section}; + + + } + push @{$doc}, "=back" if $level > 0 + } +}; + +sub makepod($) { + my $self = shift; + my $tree = $self->{grammar}; + my @doc; + _genpod $tree,0,\@doc; + return join("\n\n", @doc)."\n"; +} + +sub _gentmpl($$$@); +sub _gentmpl($$$@){ + my $tree = shift; + my $level = shift; + my $doc = shift; + my @start = @_; + if (scalar @start ) { + my $section = shift @start; + my $secex =''; + my $prefix = ''; + $prefix = "# " unless $tree->{_mandatory} and + grep {$_ eq $section} @{$tree->{_mandatory}}; + if ($tree->{$section}{_example}) { + $secex = " # ( ex. $tree->{$section}{_example} )"; + } + push @{$doc}, $prefix. + (($level > 0) ? ("+" x $level)."$section" : "*** $section ***").$secex; + my $match; + foreach my $s (@{$tree->{_sections}}){ + if ($s =~ m|^/.+/$| and $section =~ /$s/ or $s eq $section) { + _gentmpl ($tree->{$s},$level+1,$doc,@start) + unless $tree eq $tree->{$s}; + $match = 1; + } + } + push @{$doc}, "# Section $section is not a valid choice" + unless $match; + } else { + if ($tree->{_vars}){ + foreach my $var (@{$tree->{_vars}}){ + push @{$doc}, "# $var = ". + ($tree->{$var}{_example} || ' * no example *'); + next unless $tree->{_mandatory} and + grep {$_ eq $var} @{$tree->{_mandatory}}; + push @{$doc}, "$var="; + } + } + + if ($tree->{_text}){ + if ($tree->{_text}{_example}){ + my $ex = $tree->{_text}{_example}; + chomp $ex; + $ex = map {"# $_"} split /\n/, $ex; + push @{$doc}, "$ex\n"; + } + } + if ($tree->{_table}){ + my $table = "# table\n#"; + for (my $i=0;$i < $tree->{_table}{_columns}; $i++){ + $table .= ' "'.($tree->{_table}{$i}{_example} || "C$i").'"'; + } + push @{$doc}, $table; + } + if ($tree->{_sections}){ + foreach my $section (@{$tree->{_sections}}){ + my $opt = ( $tree->{_mandatory} and + grep {$_ eq $section} @{$tree->{_mandatory}} ) ? + "":"\n# optional section\n"; + my $prefix = ''; + $prefix = "# " unless $tree->{_mandatory} and + grep {$_ eq $section} @{$tree->{_mandatory}}; + my $secex =""; + if ($section =~ m|^/.+/$| && $tree->{$section}{_example}) { + $secex = " # ( ex. $tree->{$section}{_example} )"; + } + push @{$doc}, $prefix. + (($level > 0) ? ("+" x $level)."$section" : "*** $section ***"). + $secex; + _gentmpl ($tree->{$section},$level+1,$doc,@start) + unless $tree eq $tree->{$section}; + } + } + } +}; + +sub maketmpl ($@) { + my $self = shift; + my @start = @_; + my $tree = $self->{grammar}; + my @tmpl; + _gentmpl $tree,0,\@tmpl,@start; + return join("\n", @tmpl)."\n"; +} + +sub parse($$) +{ + my $self = shift; + my $file = shift; + + $self->{cfg} = {}; + $self->{level} = 0; + $self->{cfg_stack} = []; + $self->{grammar_stack} = []; + $self->{file_stack} = []; + $self->{line_stack} = []; + + # we work with a copy of the grammar so the _dyn subs may change it + local $self->{grammar} = _deepcopy($self->{grammar}); + + $self->_parse_file($file) or return undef; + + $self->_goto_level(0, undef) or return undef; + + # fill in the top level values from _default keywords + $self->_fill_defaults; + + $self->_check_mandatory($self->{grammar}, $self->{cfg}, undef) + or return undef; + + return $self->{cfg}; + +} + +1 + +__END__ +=head1 NAME + +ISG::ParseConfig - Simple config parser + +=head1 SYNOPSIS + + use ISG::ParseConfig; + + my $parser = ISG::ParseConfig->new(\%grammar); + my $cfg = $parser->parse('app.cfg') or die "ERROR: $parser->{err}\n"; + my $pod = $parser->makepod(); + my $ex = $parser->maketmpl('TOP','SubNode'); + +=head1 DESCRIPTION + +ISG::ParseConfig is a module to parse configuration files. The +configuration may consist of multiple-level sections with assignments +and tabular data. The parsed data will be returned as a hash +containing the whole configuration. ISG::ParseConfig uses a grammar +that is supplied upon creation of a ISG::ParseConfig object to parse +the configuration file and return helpful error messages in case of +syntax errors. Using the B<makepod> methode you can generate +documentation of the configuration file format. + +The B<maketmpl> method can generate a template configuration file. If +your grammar contains regexp matches, the template will not be all +that helpful as ParseConfig is not smart enough to give you sensible +template data based in regular expressions. + +=head2 Grammar Definition + +The grammar is a multiple-level hash of hashes, which follows the structure of +the configuration. Each section or variable is represented by a hash with the +same structure. Each hash contains special keys starting with an underscore +such as '_sections', '_vars', '_sub' or '_re' to denote meta data with information +about that section or variable. Other keys are used to structure the hash +according to the same nesting structure of the configuration itself. The +starting hash given as parameter to 'new' contains the "root section". + +=head3 Special Section Keys + +=over 12 + +=item _sections + +Array containing the list of sub-sections of this section. Each sub-section +must then be represented by a sub-hash in this hash with the same name of the +sub-section. + +The sub-section can also be a regular expression denoted by the syntax '/re/', +where re is the regular-expression. In case a regular expression is used, a +sub-hash named with the same '/re/' must be included in this hash. + +=item _recursive + +Array containing the list of those sub-sections that are I<recursive>, ie. +that can contain a new sub-section with the same syntax as themselves. + +The same effect can be accomplished with circular references in the +grammar tree or a suitable B<_dyn> section subroutine (see below}, +so this facility is included just for convenience. + +=item _vars + +Array containing the list of variables (assignments) in this section. +Analogous to sections, regular expressions can be used. + +=item _mandatory + +Array containing the list of mandatory sections and variables. + +=item _inherited + +Array containing the list of the variables that should be assigned the +same value as in the parent section if nothing is specified here. + +=item _table + +Hash containing the table grammar (see Special Table Keys). If not specified, +no table is allowed in this section. The grammar of the columns if specified +by sub-hashes named with the column number. + +=item _text + +Section contains free-form text. Only sections and @includes statements will +be interpreted, the rest will be added in the returned hash under '_text' as +string. + +B<_text> is a hash reference which can contain a B<_re> and a B<_re_error> key +which will be used to scrutanize the text ... if the hash is empty, all text +will be accepted. + +=item _order + +If defined, a '_order' element will be put in every hash containing the +sections with a number that determines the order in which the sections were +defined. + +=item _doc + +Describes what this section is about + +=item _dyn + +A subroutine reference (function pointer) that will be called when +a new section of this syntax is encountered. The subroutine will get +three arguments: the syntax of the section name (string or regexp), the +actual name encountered (this will be the same as the first argument for +non-regexp sections) and a reference to the grammar tree of the section. +This subroutine can then modify the grammar tree dynamically. + +=back + +=head3 Special Variable Keys + +=over 12 + +=item _re + +Regular expression upon which the value will be checked. + +=item _re_error + +String containing the returned error in case the regular expression doesn't +match (if not specified, a generic 'syntax error' message will be returned). + +=item _sub + +A function pointer. It called for every value, with the value passed as its +first argument. If the function returns a defined value it is assumed that +the test was not successful and an error is generated with the returned +string as content. + +=item _default + +A default value that will be assigned to the variable if none is specified or inherited. + +=item _doc + +Describtion of the variable. + +=item _example + +A one line example for the content of this variable. + +=item _dyn + +A subroutine reference (function pointer) that will be called when the +variable is assigned some value in the config file. The subroutine will +get three arguments: the name of the variable, the value assigned and +a reference to the grammar tree of this section. This subroutine can +then modify the grammar tree dynamically. + +Note that no _dyn() call is made for default and inherited values of +the variable. + +=back + +=head3 Special Table Keys + +=over 12 + +=item _columns + +Number of columns. If not specified, it will not be enforced. + +=item _key + +If defined, the specified column number will be used as key in a hash in the +returned hash. If not defined, the returned hash will contain a '_table' +element with the contents of the table as array. The rows of the tables are +stored as arrays. + +=item _sub + +they work analog to the description in the previous section. + +=item _doc + +describes the content of the column. + +=item _example + +example for the content of this column + +=back + +=head3 Special Text Keys + +=over 12 + +=item _re + +Regular expression upon which the text will be checked (everything as a single +line). + +=item _re_error + +String containing the returned error in case the regular expression doesn't +match (if not specified, a generic 'syntax error' message will be returned). + +=item _sub + +they work analog to the description in the previous section. + +=item _doc + +Ditto. + +=item _example + +Potential multi line example for the content of this text section + +=back + +=head2 Configuration Syntax + +=head3 General Syntax + +'#' denotes a comment up to the end-of-line, empty lines are allowed and space +at the beginning and end of lines is trimmed. + +'\' at the end of the line marks a continued line on the next line. A single +space will be inserted between the concatenated lines. + +'@include filename' is used to include another file. + +'@define a some value' will replace all occurences of 'a' in the following text +with 'some value'. + +Fields in tables that contain white space can be enclosed in either C<'> or C<">. +Whitespace can also be escaped with C<\>. Quotes inside quotes are allowed but must +be escaped with a backslash as well. + +=head3 Sections + +ISG::ParseConfig supports hierarchical configurations through sections, whose +syntax is as follows: + +=over 15 + +=item Level 1 + +*** section name *** + +=item Level 2 + ++ section name + +=item Level 3 + +++ section name + +=item Level n, n>1 + ++..+ section name (number of '+' determines level) + +=back + +=head3 Assignments + +Assignements take the form: 'variable = value', where value can be any string +(can contain whitespaces and special characters). The spaces before and after +the equal sign are optional. + +=head3 Tabular Data + +The data is interpreted as one or more columns separated by spaces. + +=head2 Example + +=head3 Code + + my $parser = ISG::ParseConfig->new({ + _sections => [ 'network', 'hosts' ], + network => { + _vars => [ 'dns' ], + _sections => [ "/$RE_IP/" ], + dns => { + _doc => "address of the dns server", + _example => "ns1.oetiker.xs", + _re => $RE_HOST, + _re_error => + 'dns must be an host name or ip address', + }, + "/$RE_IP/" => { + _doc => "Ip Adress", + _example => '10.2.3.2', + _vars => [ 'netmask', 'gateway' ], + netmask => { + _doc => "Netmask", + _example => "255.255.255.0", + _re => $RE_IP, + _re_error => + 'netmask must be a dotted ip address' + }, + gateway => { + _doc => "Default Gateway address in IP notation", + _example => "10.22.12.1", + _re => $RE_IP, + _re_error => + 'gateway must be a dotted ip address' }, + }, + }, + hosts => { + _doc => "Details about the hosts", + _table => { + _doc => "Description of all the Hosts", + _key => 0, + _columns => 3, + 0 => { + _doc => "Ethernet Address", + _example => "0:3:3:d:a:3:dd:a:cd", + _re => $RE_MAC, + _re_error => + 'first column must be an ethernet mac address', + }, + 1 => { + _doc => "IP Address", + _example => "10.11.23.1", + _re => $RE_IP, + _re_error => + 'second column must be a dotted ip address', + }, + 2 => { + _doc => "Host Name", + _example => "tardis", + }, + }, + }, + }); + + my $cfg = $parser->parse('test.cfg') or + die "ERROR: $parser->{err}\n"; + print Dumper($cfg); + print $praser->makepod; + +=head3 Configuration + + *** network *** + + dns = 129.132.7.87 + + + 129.132.7.64 + + netmask = 255.255.255.192 + gateway = 129.132.7.65 + + *** hosts *** + + 00:50:fe:bc:65:11 129.132.7.97 plain.hades + 00:50:fe:bc:65:12 129.132.7.98 isg.ee.hades + 00:50:fe:bc:65:14 129.132.7.99 isg.ee.hades + +=head3 Result + + { + 'hosts' => { + '00:50:fe:bc:65:11' => [ + '00:50:fe:bc:65:11', + '129.132.7.97', + 'plain.hades' + ], + '00:50:fe:bc:65:12' => [ + '00:50:fe:bc:65:12', + '129.132.7.98', + 'isg.ee.hades' + ], + '00:50:fe:bc:65:14' => [ + '00:50:fe:bc:65:14', + '129.132.7.99', + 'isg.ee.hades' + ] + }, + 'network' => { + '129.132.7.64' => { + 'netmask' => '255.255.255.192', + 'gateway' => '129.132.7.65' + }, + 'dns' => '129.132.7.87' + } + }; + +=head1 COPYRIGHT + +Copyright (c) 2000, 2001 by ETH Zurich. All rights reserved. + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +=head1 AUTHOR + +S<David Schweikert E<lt>dws@ee.ethz.chE<gt>> +S<Tobias Oetiker E<lt>oetiker@ee.ethz.chE<gt>> + +=head1 HISTORY + + 2001-05-11 ds 1.2 Initial Version for policy 0.3 + 2001-09-04 ds 1.3 Remove space before comments, more strict variable definition + 2001-09-19 to 1.4 Added _sub error parsing and _doc self documentation + 2001-10-20 to Improved Rendering of _doc information + 2002-01-09 to Added Documentation to the _text section documentation + 2002-01-28 to Fixed quote parsing in tables + 2002-03-12 ds 1.5 Implemented @define, make makepod return a string and not an array + 2002-08-28 to Added maketmpl methode + 2002-10-10 ds 1.6 More verbatim _text sections + 2004-02-09 to 1.7 Added _example propperty for pod and template generation + 2004-08-17 to 1.8 Allow special input files like "program|" + 2005-01-10 ds 1.9 Implemented _dyn, _default, _recursive, and _inherited (Niko Tyni) + +=cut + +# Emacs Configuration +# +# Local Variables: +# mode: cperl +# eval: (cperl-set-style "PerlStyle") +# mode: flyspell +# mode: flyspell-prog +# End: +# +# vi: sw=4 diff --git a/lib/SNMP_Session.pm b/lib/SNMP_Session.pm new file mode 100644 index 0000000..34bde10 --- /dev/null +++ b/lib/SNMP_Session.pm @@ -0,0 +1,1092 @@ +### -*- mode: Perl -*- +###################################################################### +### SNMP Request/Response Handling +###################################################################### +### Copyright (c) 1995-2002, Simon Leinen. +### +### This program is free software; you can redistribute it under the +### "Artistic License" included in this distribution (file "Artistic"). +###################################################################### +### The abstract class SNMP_Session defines objects that can be used +### to communicate with SNMP entities. It has methods to send +### requests to and receive responses from an agent. +### +### Two instantiable subclasses are defined: +### SNMPv1_Session implements SNMPv1 (RFC 1157) functionality +### SNMPv2c_Session implements community-based SNMPv2. +###################################################################### +### Created by: Simon Leinen <simon@switch.ch> +### +### Contributions and fixes by: +### +### Matthew Trunnell <matter@media.mit.edu> +### Tobias Oetiker <oetiker@ee.ethz.ch> +### Heine Peters <peters@dkrz.de> +### Daniel L. Needles <dan_needles@INS.COM> +### Mike Mitchell <mcm@unx.sas.com> +### Clinton Wong <clintdw@netcom.com> +### Alan Nichols <Alan.Nichols@Ebay.Sun.COM> +### Mike McCauley <mikem@open.com.au> +### Andrew W. Elble <elble@icculus.nsg.nwu.edu> +### Brett T Warden <wardenb@eluminant.com>: pretty UInteger32 +### Michael Deegan <michael@cnspc18.murdoch.edu.au> +### Sergio Macedo <macedo@tmp.com.br> +### Jakob Ilves (/IlvJa) <jakob.ilves@oracle.com>: PDU capture +### Valerio Bontempi <v.bontempi@inwind.it>: IPv6 support +### Lorenzo Colitti <lorenzo@colitti.com>: IPv6 support +### Philippe Simonet <Philippe.Simonet@swisscom.com>: Export avoid... +###################################################################### + +package SNMP_Session; + +require 5.002; + +use strict; +use Exporter; +use vars qw(@ISA $VERSION @EXPORT $errmsg + $suppress_warnings + $default_avoid_negative_request_ids); +use Socket; +use BER '0.95'; +use Carp; + +sub map_table ($$$ ); +sub map_table_4 ($$$$); +sub map_table_start_end ($$$$$$); +sub index_compare ($$); +sub oid_diff ($$); + +$VERSION = '0.98'; + +@ISA = qw(Exporter); + +@EXPORT = qw(errmsg suppress_warnings index_compare oid_diff recycle_socket ipv6available); + +my $default_debug = 0; + +### Default initial timeout (in seconds) waiting for a response PDU +### after a request is sent. Note that when a request is retried, the +### timeout is increased by BACKOFF (see below). +### +my $default_timeout = 2.0; + +### Default number of attempts to get a reply for an SNMP request. If +### no response is received after TIMEOUT seconds, the request is +### resent and a new response awaited with a longer timeout (see the +### documentation on BACKOFF below). The "retries" value should be at +### least 1, because the first attempt counts, too (the name "retries" +### is confusing, sorry for that). +### +my $default_retries = 5; + +### Default backoff factor for SNMP_Session objects. This factor is +### used to increase the TIMEOUT every time an SNMP request is +### retried. +### +my $default_backoff = 1.0; + +### Default value for maxRepetitions. This specifies how many table +### rows are requested in getBulk requests. Used when walking tables +### using getBulk (only available in SNMPv2(c) and later). If this is +### too small, then a table walk will need unnecessarily many +### request/response exchanges. If it is too big, the agent may +### compute many variables after the end of the table. It is +### recommended to set this explicitly for each table walk by using +### map_table_4(). +### +my $default_max_repetitions = 12; + +### Default value for "avoid_negative_request_ids". +### +### Set this to non-zero if you have agents that have trouble with +### negative request IDs, and don't forget to complain to your agent +### vendor. According to the spec (RFC 1905), the request-id is an +### Integer32, i.e. its range is from -(2^31) to (2^31)-1. However, +### some agents erroneously encode the response ID as an unsigned, +### which prevents this code from matching such responses to requests. +### +$SNMP_Session::default_avoid_negative_request_ids = 0; + +### Whether all SNMP_Session objects should share a single UDP socket. +### +$SNMP_Session::recycle_socket = 0; + +### IPv6 initialization code: check that IPv6 libraries are available, +### and if so load them. + +### We store the length of an IPv6 socket address structure in the class +### so we can determine if a socket address is IPv4 or IPv6 just by checking +### its length. The proper way to do this would be to use sockaddr_family(), +### but this function is only available in recent versions of Socket.pm. +my $ipv6_addr_len; + +BEGIN { + $ipv6_addr_len = undef; + $SNMP_Session::ipv6available = 0; + + if (eval {require Socket6;} && + eval {require IO::Socket::INET6; IO::Socket::INET6->VERSION("1.26");}) { + import Socket6; + $ipv6_addr_len = length(pack_sockaddr_in6(161, inet_pton(AF_INET6(), "::1"))); + $SNMP_Session::ipv6available = 1; + } +} + +my $the_socket; + +$SNMP_Session::errmsg = ''; +$SNMP_Session::suppress_warnings = 0; + +sub get_request { 0 | context_flag }; +sub getnext_request { 1 | context_flag }; +sub get_response { 2 | context_flag }; +sub set_request { 3 | context_flag }; +sub trap_request { 4 | context_flag }; +sub getbulk_request { 5 | context_flag }; +sub inform_request { 6 | context_flag }; +sub trap2_request { 7 | context_flag }; + +sub standard_udp_port { 161 }; + +sub open +{ + return SNMPv1_Session::open (@_); +} + +sub timeout { $_[0]->{timeout} } +sub retries { $_[0]->{retries} } +sub backoff { $_[0]->{backoff} } +sub set_timeout { + my ($session, $timeout) = @_; + croak ("timeout ($timeout) must be a positive number") unless $timeout > 0.0; + $session->{'timeout'} = $timeout; +} +sub set_retries { + my ($session, $retries) = @_; + croak ("retries ($retries) must be a non-negative integer") + unless $retries == int ($retries) && $retries >= 0; + $session->{'retries'} = $retries; +} +sub set_backoff { + my ($session, $backoff) = @_; + croak ("backoff ($backoff) must be a number >= 1.0") + unless $backoff == int ($backoff) && $backoff >= 1.0; + $session->{'backoff'} = $backoff; +} + +sub encode_request_3 ($$$@) { + my($this, $reqtype, $encoded_oids_or_pairs, $i1, $i2) = @_; + my($request); + local($_); + + $this->{request_id} = ($this->{request_id} == 0x7fffffff) + ? ($this->{avoid_negative_request_ids} + ? 0x00000000 + : -0x80000000) + : $this->{request_id}+1; + foreach $_ (@{$encoded_oids_or_pairs}) { + if (ref ($_) eq 'ARRAY') { + $_ = &encode_sequence ($_->[0], $_->[1]) + || return $this->ber_error ("encoding pair"); + } else { + $_ = &encode_sequence ($_, encode_null()) + || return $this->ber_error ("encoding value/null pair"); + } + } + $request = encode_tagged_sequence + ($reqtype, + encode_int ($this->{request_id}), + defined $i1 ? encode_int ($i1) : encode_int_0 (), + defined $i2 ? encode_int ($i2) : encode_int_0 (), + encode_sequence (@{$encoded_oids_or_pairs})) + || return $this->ber_error ("encoding request PDU"); + return $this->wrap_request ($request); +} + +sub encode_get_request { + my($this, @oids) = @_; + return encode_request_3 ($this, get_request, \@oids); +} + +sub encode_getnext_request { + my($this, @oids) = @_; + return encode_request_3 ($this, getnext_request, \@oids); +} + +sub encode_getbulk_request { + my($this, $non_repeaters, $max_repetitions, @oids) = @_; + return encode_request_3 ($this, getbulk_request, \@oids, + $non_repeaters, $max_repetitions); +} + +sub encode_set_request { + my($this, @encoded_pairs) = @_; + return encode_request_3 ($this, set_request, \@encoded_pairs); +} + +sub encode_trap_request ($$$$$$@) { + my($this, $ent, $agent, $gen, $spec, $dt, @pairs) = @_; + my($request); + local($_); + + foreach $_ (@pairs) { + if (ref ($_) eq 'ARRAY') { + $_ = &encode_sequence ($_->[0], $_->[1]) + || return $this->ber_error ("encoding pair"); + } else { + $_ = &encode_sequence ($_, encode_null()) + || return $this->ber_error ("encoding value/null pair"); + } + } + $request = encode_tagged_sequence + (trap_request, $ent, $agent, $gen, $spec, $dt, encode_sequence (@pairs)) + || return $this->ber_error ("encoding trap PDU"); + return $this->wrap_request ($request); +} + +sub encode_v2_trap_request ($@) { + my($this, @pairs) = @_; + + return encode_request_3($this, trap2_request, \@pairs); +} + +sub decode_get_response { + my($this, $response) = @_; + my @rest; + @{$this->{'unwrapped'}}; +} + +sub decode_trap_request ($$) { + my ($this, $trap) = @_; + my ($snmp_version, $community, $ent, $agent, $gen, $spec, $dt, + $request_id, $error_status, $error_index, + $bindings); + ($snmp_version, $community, + $ent, $agent, + $gen, $spec, $dt, + $bindings) + = decode_by_template ($trap, "%{%i%s%*{%O%A%i%i%u%{%@", + trap_request); + if (! defined ($snmp_version)) { + ($snmp_version, $community, + $request_id, $error_status, $error_index, + $bindings) + = decode_by_template ($trap, "%{%i%s%*{%i%i%i%{%@", + trap2_request); + return $this->error_return ("v2 trap request contained errorStatus/errorIndex " + .$error_status."/".$error_index) + if defined $error_status && defined $error_index + && ($error_status != 0 || $error_index != 0); + } + if (!defined $snmp_version) { + return $this->error_return ("BER error decoding trap:\n ".$BER::errmsg); + } + return ($community, $ent, $agent, $gen, $spec, $dt, $bindings); +} + +sub wait_for_response { + my($this) = shift; + my($timeout) = shift || 10.0; + my($rin,$win,$ein) = ('','',''); + my($rout,$wout,$eout); + vec($rin,$this->sockfileno,1) = 1; + select($rout=$rin,$wout=$win,$eout=$ein,$timeout); +} + +sub get_request_response ($@) { + my($this, @oids) = @_; + return $this->request_response_5 ($this->encode_get_request (@oids), + get_response, \@oids, 1); +} + +sub set_request_response ($@) { + my($this, @pairs) = @_; + return $this->request_response_5 ($this->encode_set_request (@pairs), + get_response, \@pairs, 1); +} + +sub getnext_request_response ($@) { + my($this,@oids) = @_; + return $this->request_response_5 ($this->encode_getnext_request (@oids), + get_response, \@oids, 1); +} + +sub getbulk_request_response ($$$@) { + my($this,$non_repeaters,$max_repetitions,@oids) = @_; + return $this->request_response_5 + ($this->encode_getbulk_request ($non_repeaters,$max_repetitions,@oids), + get_response, \@oids, 1); +} + +sub trap_request_send ($$$$$$@) { + my($this, $ent, $agent, $gen, $spec, $dt, @pairs) = @_; + my($req); + + $req = $this->encode_trap_request ($ent, $agent, $gen, $spec, $dt, @pairs); + ## Encoding may have returned an error. + return undef unless defined $req; + $this->send_query($req) + || return $this->error ("send_trap: $!"); + return 1; +} + +sub v2_trap_request_send ($$$@) { + my($this, $trap_oid, $dt, @pairs) = @_; + my @sysUptime_OID = ( 1,3,6,1,2,1,1,3 ); + my @snmpTrapOID_OID = ( 1,3,6,1,6,3,1,1,4,1 ); + my($req); + + unshift @pairs, [encode_oid (@snmpTrapOID_OID,0), + encode_oid (@{$trap_oid})]; + unshift @pairs, [encode_oid (@sysUptime_OID,0), + encode_timeticks ($dt)]; + $req = $this->encode_v2_trap_request (@pairs); + ## Encoding may have returned an error. + return undef unless defined $req; + $this->send_query($req) + || return $this->error ("send_trap: $!"); + return 1; +} + +sub request_response_5 ($$$$$) { + my ($this, $req, $response_tag, $oids, $errorp) = @_; + my $retries = $this->retries; + my $timeout = $this->timeout; + my ($nfound, $timeleft); + + ## Encoding may have returned an error. + return undef unless defined $req; + + $timeleft = $timeout; + while ($retries > 0) { + $this->send_query ($req) + || return $this->error ("send_query: $!"); + # IlvJa + # Add request pdu to capture_buffer + push @{$this->{'capture_buffer'}}, $req + if (defined $this->{'capture_buffer'} + and ref $this->{'capture_buffer'} eq 'ARRAY'); + # + + wait_for_response: + ($nfound, $timeleft) = $this->wait_for_response($timeleft); + if ($nfound > 0) { + my($response_length); + + $response_length + = $this->receive_response_3 ($response_tag, $oids, $errorp); + if ($response_length) { + # IlvJa + # Add response pdu to capture_buffer + push (@{$this->{'capture_buffer'}}, + substr($this->{'pdu_buffer'}, 0, $response_length) + ) + if (defined $this->{'capture_buffer'} + and ref $this->{'capture_buffer'} eq 'ARRAY'); + # + + + return $response_length; + } elsif (defined ($response_length)) { + goto wait_for_response; + # A response has been received, but for a different + # request ID or from a different IP address. + } else { + return undef; + } + } else { + ## No response received - retry + --$retries; + $timeout *= $this->backoff; + $timeleft = $timeout; + } + } + # IlvJa + # Add empty packet to capture_buffer + push @{$this->{'capture_buffer'}}, "" + if (defined $this->{'capture_buffer'} + and ref $this->{'capture_buffer'} eq 'ARRAY'); + # + + $this->error ("no response received"); +} + +sub map_table ($$$) { + my ($session, $columns, $mapfn) = @_; + return $session->map_table_4 ($columns, $mapfn, + $session->default_max_repetitions ()); +} + +sub map_table_4 ($$$$) { + my ($session, $columns, $mapfn, $max_repetitions) = @_; + return $session->map_table_start_end ($columns, $mapfn, + "", undef, + $max_repetitions); +} + +sub map_table_start_end ($$$$$$) { + my ($session, $columns, $mapfn, $start, $end, $max_repetitions) = @_; + + my @encoded_oids; + my $call_counter = 0; + my $base_index = $start; + + do { + foreach (@encoded_oids = @{$columns}) { + $_=encode_oid (@{$_},split '\.',$base_index) + || return $session->ber_error ("encoding OID $base_index"); + } + if ($session->getnext_request_response (@encoded_oids)) { + my $response = $session->pdu_buffer; + my ($bindings) = $session->decode_get_response ($response); + my $smallest_index = undef; + my @collected_values = (); + + my @bases = @{$columns}; + while ($bindings ne '') { + my ($binding, $oid, $value); + my $base = shift @bases; + ($binding, $bindings) = decode_sequence ($bindings); + ($oid, $value) = decode_by_template ($binding, "%O%@"); + + my $out_index; + + $out_index = &oid_diff ($base, $oid); + my $cmp; + if (!defined $smallest_index + || ($cmp = index_compare ($out_index,$smallest_index)) == -1) { + $smallest_index = $out_index; + grep ($_=undef, @collected_values); + push @collected_values, $value; + } elsif ($cmp == 1) { + push @collected_values, undef; + } else { + push @collected_values, $value; + } + } + (++$call_counter, + &$mapfn ($smallest_index, @collected_values)) + if defined $smallest_index; + $base_index = $smallest_index; + } else { + return undef; + } + } + while (defined $base_index + && (!defined $end || index_compare ($base_index, $end) < 0)); + $call_counter; +} + +sub index_compare ($$) { + my ($i1, $i2) = @_; + $i1 = '' unless defined $i1; + $i2 = '' unless defined $i2; + if ($i1 eq '') { + return $i2 eq '' ? 0 : 1; + } elsif ($i2 eq '') { + return 1; + } elsif (!$i1) { + return $i2 eq '' ? 1 : !$i2 ? 0 : 1; + } elsif (!$i2) { + return -1; + } else { + my ($f1,$r1) = split('\.',$i1,2); + my ($f2,$r2) = split('\.',$i2,2); + + if ($f1 < $f2) { + return -1; + } elsif ($f1 > $f2) { + return 1; + } else { + return index_compare ($r1,$r2); + } + } +} + +sub oid_diff ($$) { + my($base, $full) = @_; + my $base_dotnot = join ('.',@{$base}); + my $full_dotnot = BER::pretty_oid ($full); + + return undef unless substr ($full_dotnot, 0, length $base_dotnot) + eq $base_dotnot + && substr ($full_dotnot, length $base_dotnot, 1) eq '.'; + substr ($full_dotnot, length ($base_dotnot)+1); +} + +# Pretty_address returns a human-readable representation of an IPv4 or IPv6 address. +sub pretty_address { + my($addr) = shift; + my($port, $addrunpack, $addrstr); + + # Disable strict subs to stop old versions of perl from + # complaining about AF_INET6 when Socket6 is not available + + if( (defined $ipv6_addr_len) && (length $addr == $ipv6_addr_len)) { + ($port,$addrunpack) = unpack_sockaddr_in6 ($addr); + $addrstr = inet_ntop (AF_INET6(), $addrunpack); + } else { + ($port,$addrunpack) = unpack_sockaddr_in ($addr); + $addrstr = inet_ntoa ($addrunpack); + } + + return sprintf ("[%s].%d", $addrstr, $port); +} + +sub version { $VERSION; } + + +sub error_return ($$) { + my ($this,$message) = @_; + $SNMP_Session::errmsg = $message; + unless ($SNMP_Session::suppress_warnings) { + $message =~ s/^/ /mg; + carp ("Error:\n".$message."\n"); + } + return undef; +} + +sub error ($$) { + my ($this,$message) = @_; + my $session = $this->to_string; + $SNMP_Session::errmsg = $message."\n".$session; + unless ($SNMP_Session::suppress_warnings) { + $session =~ s/^/ /mg; + $message =~ s/^/ /mg; + carp ("SNMP Error:\n".$SNMP_Session::errmsg."\n"); + } + return undef; +} + +sub ber_error ($$) { + my ($this,$type) = @_; + my ($errmsg) = $BER::errmsg; + + $errmsg =~ s/^/ /mg; + return $this->error ("$type:\n$errmsg"); +} + +package SNMPv1_Session; + +use strict qw(vars subs); # see above +use vars qw(@ISA); +use SNMP_Session; +use Socket; +use BER; +use IO::Socket; +use Carp; + +BEGIN { + if($SNMP_Session::ipv6available) { + import IO::Socket::INET6; + import Socket6; + } +} + +@ISA = qw(SNMP_Session); + +sub snmp_version { 0 } + +# Supports both IPv4 and IPv6. +# Numeric IPv6 addresses must be passed between square brackets [] +sub open { + my($this, + $remote_hostname,$community,$port, + $max_pdu_len,$local_port,$max_repetitions, + $local_hostname,$ipv4only) = @_; + my($remote_addr,$socket,$sockfamily); + + $ipv4only = 1 unless defined $ipv4only; + $sockfamily = AF_INET; + + $community = 'public' unless defined $community; + $port = SNMP_Session::standard_udp_port unless defined $port; + $max_pdu_len = 8000 unless defined $max_pdu_len; + $max_repetitions = $default_max_repetitions + unless defined $max_repetitions; + + if ($ipv4only || ! $SNMP_Session::ipv6available) { + # IPv4-only code, uses only Socket and INET calls + if (defined $remote_hostname) { + $remote_addr = inet_aton ($remote_hostname) + or return $this->error_return ("can't resolve \"$remote_hostname\" to IP address"); + } + if ($SNMP_Session::recycle_socket && defined $the_socket) { + $socket = $the_socket; + } else { + $socket = IO::Socket::INET->new(Proto => 17, + Type => SOCK_DGRAM, + LocalAddr => $local_hostname, + LocalPort => $local_port) + || return $this->error_return ("creating socket: $!"); + $the_socket = $socket + if $SNMP_Session::recycle_socket; + } + $remote_addr = pack_sockaddr_in ($port, $remote_addr) + if defined $remote_addr; + } else { + # IPv6-capable code. Will use IPv6 or IPv4 depending on the address. + # Uses Socket6 and INET6 calls. + + # If it's a numeric IPv6 addresses, remove square brackets + if ($remote_hostname =~ /^\[(.*)\]$/) { + $remote_hostname = $1; + } + + my (@res, $socktype_tmp, $proto_tmp, $canonname_tmp); + @res = getaddrinfo($remote_hostname, $port, AF_UNSPEC, SOCK_DGRAM); + ($sockfamily, $socktype_tmp, $proto_tmp, $remote_addr, $canonname_tmp) = @res; + if (scalar(@res) < 5) { + return $this->error_return ("can't resolve \"$remote_hostname\" to IPv6 address"); + } + + if ($SNMP_Session::recycle_socket && defined $the_socket) { + $socket = $the_socket; + } elsif ($sockfamily == AF_INET) { + $socket = IO::Socket::INET->new(Proto => 17, + Type => SOCK_DGRAM, + LocalAddr => $local_hostname, + LocalPort => $local_port) + || return $this->error_return ("creating socket: $!"); + } else { + $socket = IO::Socket::INET6->new(Proto => 17, + Type => SOCK_DGRAM, + LocalAddr => $local_hostname, + LocalPort => $local_port) + || return $this->error_return ("creating socket: $!"); + $the_socket = $socket + if $SNMP_Session::recycle_socket; + } + } + bless { + 'sock' => $socket, + 'sockfileno' => fileno ($socket), + 'community' => $community, + 'remote_hostname' => $remote_hostname, + 'remote_addr' => $remote_addr, + 'sockfamily' => $sockfamily, + 'max_pdu_len' => $max_pdu_len, + 'pdu_buffer' => '\0' x $max_pdu_len, + 'request_id' => + $SNMP_Session::default_avoid_negative_request_ids + ? (int (rand 0x8000) << 16) + int (rand 0x10000) + : (int (rand 0x10000) << 16) + int (rand 0x10000) + - 0x80000000, + 'timeout' => $default_timeout, + 'retries' => $default_retries, + 'backoff' => $default_backoff, + 'debug' => $default_debug, + 'error_status' => 0, + 'error_index' => 0, + 'default_max_repetitions' => $max_repetitions, + 'use_getbulk' => 1, + 'lenient_source_address_matching' => 1, + 'lenient_source_port_matching' => 1, + 'avoid_negative_request_ids' => $SNMP_Session::default_avoid_negative_request_ids, + 'capture_buffer' => undef, + }; +} + +sub open_trap_session (@) { + my ($this, $port) = @_; + $port = 162 unless defined $port; + return $this->open (undef, "", 161, undef, $port); +} + +sub sock { $_[0]->{sock} } +sub sockfileno { $_[0]->{sockfileno} } +sub remote_addr { $_[0]->{remote_addr} } +sub pdu_buffer { $_[0]->{pdu_buffer} } +sub max_pdu_len { $_[0]->{max_pdu_len} } +sub default_max_repetitions { + defined $_[1] + ? $_[0]->{default_max_repetitions} = $_[1] + : $_[0]->{default_max_repetitions} } +sub debug { defined $_[1] ? $_[0]->{debug} = $_[1] : $_[0]->{debug} } + +sub close { + my($this) = shift; + ## Avoid closing the socket if it may be shared with other session + ## objects. + if (! defined $the_socket || $this->sock ne $the_socket) { + close ($this->sock) || $this->error ("close: $!"); + } +} + +sub wrap_request { + my($this) = shift; + my($request) = shift; + + encode_sequence (encode_int ($this->snmp_version), + encode_string ($this->{community}), + $request) + || return $this->ber_error ("wrapping up request PDU"); +} + +my @error_status_code = qw(noError tooBig noSuchName badValue readOnly + genErr noAccess wrongType wrongLength + wrongEncoding wrongValue noCreation + inconsistentValue resourceUnavailable + commitFailed undoFailed authorizationError + notWritable inconsistentName); + +sub unwrap_response_5b { + my ($this,$response,$tag,$oids,$errorp) = @_; + my ($community,$request_id,@rest,$snmpver); + + ($snmpver,$community,$request_id, + $this->{error_status}, + $this->{error_index}, + @rest) + = decode_by_template ($response, "%{%i%s%*{%i%i%i%{%@", + $tag); + return $this->ber_error ("Error decoding response PDU") + unless defined $snmpver; + return $this->error ("Received SNMP response with unknown snmp-version field $snmpver") + unless $snmpver == $this->snmp_version; + if ($this->{error_status} != 0) { + if ($errorp) { + my ($oid, $errmsg); + $errmsg = $error_status_code[$this->{error_status}] || $this->{error_status}; + $oid = $oids->[$this->{error_index}-1] + if $this->{error_index} > 0 && $this->{error_index}-1 <= $#{$oids}; + $oid = $oid->[0] + if ref($oid) eq 'ARRAY'; + return ($community, $request_id, + $this->error ("Received SNMP response with error code\n" + ." error status: $errmsg\n" + ." index ".$this->{error_index} + .(defined $oid + ? " (OID: ".&BER::pretty_oid($oid).")" + : ""))); + } else { + if ($this->{error_index} == 1) { + @rest[$this->{error_index}-1..$this->{error_index}] = (); + } + } + } + ($community, $request_id, @rest); +} + +sub send_query ($$) { + my ($this,$query) = @_; + send ($this->sock,$query,0,$this->remote_addr); +} + +## Compare two sockaddr_in structures for equality. This is used when +## matching incoming responses with outstanding requests. Previous +## versions of the code simply did a bytewise comparison ("eq") of the +## two sockaddr_in structures, but this didn't work on some systems +## where sockaddr_in contains other elements than just the IP address +## and port number, notably FreeBSD. +## +## We allow for varying degrees of leniency when checking the source +## address. By default we now ignore it altogether, because there are +## agents that don't respond from UDP port 161, and there are agents +## that don't respond from the IP address the query had been sent to. +## +## The address family is stored in the session object. We could use +## sockaddr_family() to determine it from the sockaddr, but this function +## is only available in recent versions of Socket.pm. +sub sa_equal_p ($$$) { + my ($this, $sa1, $sa2) = @_; + my ($p1,$a1,$p2,$a2); + + # Disable strict subs to stop old versions of perl from + # complaining about AF_INET6 when Socket6 is not available + if($this->{'sockfamily'} == AF_INET) { + # IPv4 addresses + ($p1,$a1) = unpack_sockaddr_in ($sa1); + ($p2,$a2) = unpack_sockaddr_in ($sa2); + } elsif($this->{'sockfamily'} == AF_INET6()) { + # IPv6 addresses + ($p1,$a1) = unpack_sockaddr_in6 ($sa1); + ($p2,$a2) = unpack_sockaddr_in6 ($sa2); + } else { + return 0; + } + use strict "subs"; + + if (! $this->{'lenient_source_address_matching'}) { + return 0 if $a1 ne $a2; + } + if (! $this->{'lenient_source_port_matching'}) { + return 0 if $p1 != $p2; + } + return 1; +} + +sub receive_response_3 { + my ($this, $response_tag, $oids, $errorp) = @_; + my ($remote_addr); + $remote_addr = recv ($this->sock,$this->{'pdu_buffer'},$this->max_pdu_len,0); + return $this->error ("receiving response PDU: $!") + unless defined $remote_addr; + return $this->error ("short (".length $this->{'pdu_buffer'} + ." bytes) response PDU") + unless length $this->{'pdu_buffer'} > 2; + my $response = $this->{'pdu_buffer'}; + ## + ## Check whether the response came from the address we've sent the + ## request to. If this is not the case, we should probably ignore + ## it, as it may relate to another request. + ## + if (defined $this->{'remote_addr'}) { + if (! $this->sa_equal_p ($remote_addr, $this->{'remote_addr'})) { + if ($this->{'debug'} && !$SNMP_Session::recycle_socket) { + carp ("Response came from ".&SNMP_Session::pretty_address($remote_addr) + .", not ".&SNMP_Session::pretty_address($this->{'remote_addr'})) + unless $SNMP_Session::suppress_warnings; + } + return 0; + } + } + $this->{'last_sender_addr'} = $remote_addr; + my ($response_community, $response_id, @unwrapped) + = $this->unwrap_response_5b ($response, $response_tag, + $oids, $errorp); + if ($response_community ne $this->{community} + || $response_id ne $this->{request_id}) { + if ($this->{'debug'}) { + carp ("$response_community != $this->{community}") + unless $SNMP_Session::suppress_warnings + || $response_community eq $this->{community}; + carp ("$response_id != $this->{request_id}") + unless $SNMP_Session::suppress_warnings + || $response_id == $this->{request_id}; + } + return 0; + } + if (!defined $unwrapped[0]) { + $this->{'unwrapped'} = undef; + return undef; + } + $this->{'unwrapped'} = \@unwrapped; + return length $this->pdu_buffer; +} + +sub receive_trap { + my ($this) = @_; + my ($remote_addr, $iaddr, $port, $trap); + $remote_addr = recv ($this->sock,$this->{'pdu_buffer'},$this->max_pdu_len,0); + return undef unless $remote_addr; + + if( (defined $ipv6_addr_len) && (length $remote_addr == $ipv6_addr_len)) { + ($port,$iaddr) = unpack_sockaddr_in6($remote_addr); + } else { + ($port,$iaddr) = unpack_sockaddr_in($remote_addr); + } + + $trap = $this->{'pdu_buffer'}; + return ($trap, $iaddr, $port); +} + +sub describe { + my($this) = shift; + print $this->to_string (),"\n"; +} + +sub to_string { + my($this) = shift; + my ($class,$prefix); + + $class = ref($this); + $prefix = ' ' x (length ($class) + 2); + ($class + .(defined $this->{remote_hostname} + ? " (remote host: \"".$this->{remote_hostname}."\"" + ." ".&SNMP_Session::pretty_address ($this->remote_addr).")" + : " (no remote host specified)") + ."\n" + .$prefix." community: \"".$this->{'community'}."\"\n" + .$prefix." request ID: ".$this->{'request_id'}."\n" + .$prefix."PDU bufsize: ".$this->{'max_pdu_len'}." bytes\n" + .$prefix." timeout: ".$this->{timeout}."s\n" + .$prefix." retries: ".$this->{retries}."\n" + .$prefix." backoff: ".$this->{backoff}.")"); +## sprintf ("SNMP_Session: %s (size %d timeout %g)", +## &SNMP_Session::pretty_address ($this->remote_addr),$this->max_pdu_len, +## $this->timeout); +} + +### SNMP Agent support +### contributed by Mike McCauley <mikem@open.com.au> +### +sub receive_request { + my ($this) = @_; + my ($remote_addr, $iaddr, $port, $request); + + $remote_addr = recv($this->sock, $this->{'pdu_buffer'}, + $this->{'max_pdu_len'}, 0); + return undef unless $remote_addr; + + if( (defined $ipv6_addr_len) && (length $remote_addr == $ipv6_addr_len)) { + ($port,$iaddr) = unpack_sockaddr_in6($remote_addr); + } else { + ($port,$iaddr) = unpack_sockaddr_in($remote_addr); + } + + $request = $this->{'pdu_buffer'}; + return ($request, $iaddr, $port); +} + +sub decode_request { + my ($this, $request) = @_; + my ($snmp_version, $community, $requestid, $errorstatus, $errorindex, $bindings); + + ($snmp_version, $community, $requestid, $errorstatus, $errorindex, $bindings) + = decode_by_template ($request, "%{%i%s%*{%i%i%i%@", SNMP_Session::get_request); + if (defined $snmp_version) + { + # Its a valid get_request + return(SNMP_Session::get_request, $requestid, $bindings, $community); + } + + ($snmp_version, $community, $requestid, $errorstatus, $errorindex, $bindings) + = decode_by_template ($request, "%{%i%s%*{%i%i%i%@", SNMP_Session::getnext_request); + if (defined $snmp_version) + { + # Its a valid getnext_request + return(SNMP_Session::getnext_request, $requestid, $bindings, $community); + } + + ($snmp_version, $community, $requestid, $errorstatus, $errorindex, $bindings) + = decode_by_template ($request, "%{%i%s%*{%i%i%i%@", SNMP_Session::set_request); + if (defined $snmp_version) + { + # Its a valid set_request + return(SNMP_Session::set_request, $requestid, $bindings, $community); + } + + # Something wrong with this packet + # Decode failed + return undef; +} + +package SNMPv2c_Session; +use strict qw(vars subs); # see above +use vars qw(@ISA); +use SNMP_Session; +use BER; +use Carp; + +@ISA = qw(SNMPv1_Session); + +sub snmp_version { 1 } + +sub open { + my $session = SNMPv1_Session::open (@_); + return undef unless defined $session; + return bless $session; +} + +## map_table_start_end using get-bulk +## +sub map_table_start_end ($$$$$$) { + my ($session, $columns, $mapfn, $start, $end, $max_repetitions) = @_; + + my @encoded_oids; + my $call_counter = 0; + my $base_index = $start; + my $ncols = @{$columns}; + my @collected_values = (); + + if (! $session->{'use_getbulk'}) { + return SNMP_Session::map_table_start_end + ($session, $columns, $mapfn, $start, $end, $max_repetitions); + } + $max_repetitions = $session->default_max_repetitions + unless defined $max_repetitions; + + for (;;) { + foreach (@encoded_oids = @{$columns}) { + $_=encode_oid (@{$_},split '\.',$base_index) + || return $session->ber_error ("encoding OID $base_index"); + } + if ($session->getbulk_request_response (0, $max_repetitions, + @encoded_oids)) { + my $response = $session->pdu_buffer; + my ($bindings) = $session->decode_get_response ($response); + my @colstack = (); + my $k = 0; + my $j; + + my $min_index = undef; + + my @bases = @{$columns}; + my $n_bindings = 0; + my $binding; + + ## Copy all bindings into the colstack. + ## The colstack is a vector of vectors. + ## It contains one vector for each "repeater" variable. + ## + while ($bindings ne '') { + ($binding, $bindings) = decode_sequence ($bindings); + my ($oid, $value) = decode_by_template ($binding, "%O%@"); + + push @{$colstack[$k]}, [$oid, $value]; + ++$k; $k = 0 if $k >= $ncols; + } + + ## Now collect rows from the column stack: + ## + ## Iterate through the column stacks to find the smallest + ## index, collecting the values for that index in + ## @collected_values. + ## + ## As long as a row can be assembled, the map function is + ## called on it and the iteration proceeds. + ## + $base_index = undef; + walk_rows_from_pdu: + for (;;) { + my $min_index = undef; + + for ($k = 0; $k < $ncols; ++$k) { + $collected_values[$k] = undef; + my $pair = $colstack[$k]->[0]; + unless (defined $pair) { + $min_index = undef; + last walk_rows_from_pdu; + } + my $this_index + = SNMP_Session::oid_diff ($columns->[$k], $pair->[0]); + if (defined $this_index) { + my $cmp + = !defined $min_index + ? -1 + : SNMP_Session::index_compare + ($this_index, $min_index); + if ($cmp == -1) { + for ($j = 0; $j < $k; ++$j) { + unshift (@{$colstack[$j]}, + [$min_index, + $collected_values[$j]]); + $collected_values[$j] = undef; + } + $min_index = $this_index; + } + if ($cmp <= 0) { + $collected_values[$k] = $pair->[1]; + shift @{$colstack[$k]}; + } + } + } + ($base_index = undef), last + if !defined $min_index; + last if defined $end && index_compare ($min_index, $end) >= 0; + &$mapfn ($min_index, @collected_values); + ++$call_counter; + $base_index = $min_index; + } + } else { + return undef; + } + last if !defined $base_index; + last if defined $end and index_compare ($base_index, $end) >= 0; + } + $call_counter; +} + +1; diff --git a/lib/SNMP_util.pm b/lib/SNMP_util.pm new file mode 100644 index 0000000..d103dbc --- /dev/null +++ b/lib/SNMP_util.pm @@ -0,0 +1,1266 @@ +### - *- mode: Perl -*- +###################################################################### +### SNMP_util -- SNMP utilities using SNMP_Session.pm and BER.pm +###################################################################### +### Copyright (c) 1998-2002, Mike Mitchell. +### +### This program is free software; you can redistribute it under the +### "Artistic License" included in this distribution (file "Artistic"). +###################################################################### +### Created by: Mike Mitchell <Mike.Mitchell@sas.com> +### +### Contributions and fixes by: +### +### Tobias Oetiker <oetiker@ee.ethz.ch>: Basic layout +### Simon Leinen <simon@switch.ch>: SNMP_session.pm/BER.pm +### Jeff Allen <jeff.allen@acm.org>: length() of undefined value +### Johannes Demel <demel@zid.tuwien.ac.at>: MIB file parse problem +### Simon Leinen <simon@switch.ch>: more OIDs from Interface MIB +### Jacques Supcik <supcik@ip-plus.net>: Specify local IP, port +### Tobias Oetiker <oetiker@ee.ethz.ch>: HASH as first OID to set SNMP options +### Simon Leinen <simon@switch.ch>: 'undefined port' bug +### Daniel McDonald <dmcdonald@digicontech.com>: request for getbulk support +### Laurent Girod <girod.laurent@pmintl.ch>: code for snmpwalkhash +### Ian Duplisse <i.duplisse@cablelabs.com>: MIB parsing suggestions +### Jakob Ilves <jakob.ilves@oracle.com>: return_array_refs for snmpwalk() +### Valerio Bontempi <v.bontempi@inwind.it>: IPv6 support +### Lorenzo Colitti <lorenzo@colitti.com>: IPv6 support +### Joerg Kummer <JOERG.KUMMER@Roche.COM>: TimeTicks support in snmpset() +###################################################################### + +package SNMP_util; + +require 5.004; + +use strict; +use vars qw(@ISA @EXPORT $VERSION); +use Exporter; +use Carp; + +use BER "0.95"; +use SNMP_Session "0.97"; +use Socket; + +$VERSION = '0.98'; + +@ISA = qw(Exporter); + +@EXPORT = qw(snmpget snmpgetnext snmpwalk snmpset snmptrap snmpgetbulk snmpmaptable snmpmaptable4 snmpwalkhash snmpmapOID snmpMIB_to_OID snmpLoad_OID_Cache snmpQueue_MIB_File); + +# The OID numbers from RFC1213 (MIB-II) and RFC1315 (Frame Relay) +# are pre-loaded below. +%SNMP_util::OIDS = + ( + 'iso' => '1', + 'org' => '1.3', + 'dod' => '1.3.6', + 'internet' => '1.3.6.1', + 'directory' => '1.3.6.1.1', + 'mgmt' => '1.3.6.1.2', + 'mib-2' => '1.3.6.1.2.1', + 'system' => '1.3.6.1.2.1.1', + 'sysDescr' => '1.3.6.1.2.1.1.1.0', + 'sysObjectID' => '1.3.6.1.2.1.1.2.0', + 'sysUpTime' => '1.3.6.1.2.1.1.3.0', + 'sysUptime' => '1.3.6.1.2.1.1.3.0', + 'sysContact' => '1.3.6.1.2.1.1.4.0', + 'sysName' => '1.3.6.1.2.1.1.5.0', + 'sysLocation' => '1.3.6.1.2.1.1.6.0', + 'sysServices' => '1.3.6.1.2.1.1.7.0', + 'interfaces' => '1.3.6.1.2.1.2', + 'ifNumber' => '1.3.6.1.2.1.2.1.0', + 'ifTable' => '1.3.6.1.2.1.2.2', + 'ifEntry' => '1.3.6.1.2.1.2.2.1', + 'ifIndex' => '1.3.6.1.2.1.2.2.1.1', + 'ifInOctets' => '1.3.6.1.2.1.2.2.1.10', + 'ifInUcastPkts' => '1.3.6.1.2.1.2.2.1.11', + 'ifInNUcastPkts' => '1.3.6.1.2.1.2.2.1.12', + 'ifInDiscards' => '1.3.6.1.2.1.2.2.1.13', + 'ifInErrors' => '1.3.6.1.2.1.2.2.1.14', + 'ifInUnknownProtos' => '1.3.6.1.2.1.2.2.1.15', + 'ifOutOctets' => '1.3.6.1.2.1.2.2.1.16', + 'ifOutUcastPkts' => '1.3.6.1.2.1.2.2.1.17', + 'ifOutNUcastPkts' => '1.3.6.1.2.1.2.2.1.18', + 'ifOutDiscards' => '1.3.6.1.2.1.2.2.1.19', + 'ifDescr' => '1.3.6.1.2.1.2.2.1.2', + 'ifOutErrors' => '1.3.6.1.2.1.2.2.1.20', + 'ifOutQLen' => '1.3.6.1.2.1.2.2.1.21', + 'ifSpecific' => '1.3.6.1.2.1.2.2.1.22', + 'ifType' => '1.3.6.1.2.1.2.2.1.3', + 'ifMtu' => '1.3.6.1.2.1.2.2.1.4', + 'ifSpeed' => '1.3.6.1.2.1.2.2.1.5', + 'ifPhysAddress' => '1.3.6.1.2.1.2.2.1.6', + 'ifAdminHack' => '1.3.6.1.2.1.2.2.1.7', + 'ifAdminStatus' => '1.3.6.1.2.1.2.2.1.7', + 'ifOperHack' => '1.3.6.1.2.1.2.2.1.8', + 'ifOperStatus' => '1.3.6.1.2.1.2.2.1.8', + 'ifLastChange' => '1.3.6.1.2.1.2.2.1.9', + 'at' => '1.3.6.1.2.1.3', + 'atTable' => '1.3.6.1.2.1.3.1', + 'atEntry' => '1.3.6.1.2.1.3.1.1', + 'atIfIndex' => '1.3.6.1.2.1.3.1.1.1', + 'atPhysAddress' => '1.3.6.1.2.1.3.1.1.2', + 'atNetAddress' => '1.3.6.1.2.1.3.1.1.3', + 'ip' => '1.3.6.1.2.1.4', + 'ipForwarding' => '1.3.6.1.2.1.4.1', + 'ipOutRequests' => '1.3.6.1.2.1.4.10', + 'ipOutDiscards' => '1.3.6.1.2.1.4.11', + 'ipOutNoRoutes' => '1.3.6.1.2.1.4.12', + 'ipReasmTimeout' => '1.3.6.1.2.1.4.13', + 'ipReasmReqds' => '1.3.6.1.2.1.4.14', + 'ipReasmOKs' => '1.3.6.1.2.1.4.15', + 'ipReasmFails' => '1.3.6.1.2.1.4.16', + 'ipFragOKs' => '1.3.6.1.2.1.4.17', + 'ipFragFails' => '1.3.6.1.2.1.4.18', + 'ipFragCreates' => '1.3.6.1.2.1.4.19', + 'ipDefaultTTL' => '1.3.6.1.2.1.4.2', + 'ipAddrTable' => '1.3.6.1.2.1.4.20', + 'ipAddrEntry' => '1.3.6.1.2.1.4.20.1', + 'ipAdEntAddr' => '1.3.6.1.2.1.4.20.1.1', + 'ipAdEntIfIndex' => '1.3.6.1.2.1.4.20.1.2', + 'ipAdEntNetMask' => '1.3.6.1.2.1.4.20.1.3', + 'ipAdEntBcastAddr' => '1.3.6.1.2.1.4.20.1.4', + 'ipAdEntReasmMaxSize' => '1.3.6.1.2.1.4.20.1.5', + 'ipRouteTable' => '1.3.6.1.2.1.4.21', + 'ipRouteEntry' => '1.3.6.1.2.1.4.21.1', + 'ipRouteDest' => '1.3.6.1.2.1.4.21.1.1', + 'ipRouteAge' => '1.3.6.1.2.1.4.21.1.10', + 'ipRouteMask' => '1.3.6.1.2.1.4.21.1.11', + 'ipRouteMetric5' => '1.3.6.1.2.1.4.21.1.12', + 'ipRouteInfo' => '1.3.6.1.2.1.4.21.1.13', + 'ipRouteIfIndex' => '1.3.6.1.2.1.4.21.1.2', + 'ipRouteMetric1' => '1.3.6.1.2.1.4.21.1.3', + 'ipRouteMetric2' => '1.3.6.1.2.1.4.21.1.4', + 'ipRouteMetric3' => '1.3.6.1.2.1.4.21.1.5', + 'ipRouteMetric4' => '1.3.6.1.2.1.4.21.1.6', + 'ipRouteNextHop' => '1.3.6.1.2.1.4.21.1.7', + 'ipRouteType' => '1.3.6.1.2.1.4.21.1.8', + 'ipRouteProto' => '1.3.6.1.2.1.4.21.1.9', + 'ipNetToMediaTable' => '1.3.6.1.2.1.4.22', + 'ipNetToMediaEntry' => '1.3.6.1.2.1.4.22.1', + 'ipNetToMediaIfIndex' => '1.3.6.1.2.1.4.22.1.1', + 'ipNetToMediaPhysAddress' => '1.3.6.1.2.1.4.22.1.2', + 'ipNetToMediaNetAddress' => '1.3.6.1.2.1.4.22.1.3', + 'ipNetToMediaType' => '1.3.6.1.2.1.4.22.1.4', + 'ipRoutingDiscards' => '1.3.6.1.2.1.4.23', + 'ipInReceives' => '1.3.6.1.2.1.4.3', + 'ipInHdrErrors' => '1.3.6.1.2.1.4.4', + 'ipInAddrErrors' => '1.3.6.1.2.1.4.5', + 'ipForwDatagrams' => '1.3.6.1.2.1.4.6', + 'ipInUnknownProtos' => '1.3.6.1.2.1.4.7', + 'ipInDiscards' => '1.3.6.1.2.1.4.8', + 'ipInDelivers' => '1.3.6.1.2.1.4.9', + 'icmp' => '1.3.6.1.2.1.5', + 'icmpInMsgs' => '1.3.6.1.2.1.5.1', + 'icmpInTimestamps' => '1.3.6.1.2.1.5.10', + 'icmpInTimestampReps' => '1.3.6.1.2.1.5.11', + 'icmpInAddrMasks' => '1.3.6.1.2.1.5.12', + 'icmpInAddrMaskReps' => '1.3.6.1.2.1.5.13', + 'icmpOutMsgs' => '1.3.6.1.2.1.5.14', + 'icmpOutErrors' => '1.3.6.1.2.1.5.15', + 'icmpOutDestUnreachs' => '1.3.6.1.2.1.5.16', + 'icmpOutTimeExcds' => '1.3.6.1.2.1.5.17', + 'icmpOutParmProbs' => '1.3.6.1.2.1.5.18', + 'icmpOutSrcQuenchs' => '1.3.6.1.2.1.5.19', + 'icmpInErrors' => '1.3.6.1.2.1.5.2', + 'icmpOutRedirects' => '1.3.6.1.2.1.5.20', + 'icmpOutEchos' => '1.3.6.1.2.1.5.21', + 'icmpOutEchoReps' => '1.3.6.1.2.1.5.22', + 'icmpOutTimestamps' => '1.3.6.1.2.1.5.23', + 'icmpOutTimestampReps' => '1.3.6.1.2.1.5.24', + 'icmpOutAddrMasks' => '1.3.6.1.2.1.5.25', + 'icmpOutAddrMaskReps' => '1.3.6.1.2.1.5.26', + 'icmpInDestUnreachs' => '1.3.6.1.2.1.5.3', + 'icmpInTimeExcds' => '1.3.6.1.2.1.5.4', + 'icmpInParmProbs' => '1.3.6.1.2.1.5.5', + 'icmpInSrcQuenchs' => '1.3.6.1.2.1.5.6', + 'icmpInRedirects' => '1.3.6.1.2.1.5.7', + 'icmpInEchos' => '1.3.6.1.2.1.5.8', + 'icmpInEchoReps' => '1.3.6.1.2.1.5.9', + 'tcp' => '1.3.6.1.2.1.6', + 'tcpRtoAlgorithm' => '1.3.6.1.2.1.6.1', + 'tcpInSegs' => '1.3.6.1.2.1.6.10', + 'tcpOutSegs' => '1.3.6.1.2.1.6.11', + 'tcpRetransSegs' => '1.3.6.1.2.1.6.12', + 'tcpConnTable' => '1.3.6.1.2.1.6.13', + 'tcpConnEntry' => '1.3.6.1.2.1.6.13.1', + 'tcpConnState' => '1.3.6.1.2.1.6.13.1.1', + 'tcpConnLocalAddress' => '1.3.6.1.2.1.6.13.1.2', + 'tcpConnLocalPort' => '1.3.6.1.2.1.6.13.1.3', + 'tcpConnRemAddress' => '1.3.6.1.2.1.6.13.1.4', + 'tcpConnRemPort' => '1.3.6.1.2.1.6.13.1.5', + 'tcpInErrs' => '1.3.6.1.2.1.6.14', + 'tcpOutRsts' => '1.3.6.1.2.1.6.15', + 'tcpRtoMin' => '1.3.6.1.2.1.6.2', + 'tcpRtoMax' => '1.3.6.1.2.1.6.3', + 'tcpMaxConn' => '1.3.6.1.2.1.6.4', + 'tcpActiveOpens' => '1.3.6.1.2.1.6.5', + 'tcpPassiveOpens' => '1.3.6.1.2.1.6.6', + 'tcpAttemptFails' => '1.3.6.1.2.1.6.7', + 'tcpEstabResets' => '1.3.6.1.2.1.6.8', + 'tcpCurrEstab' => '1.3.6.1.2.1.6.9', + 'udp' => '1.3.6.1.2.1.7', + 'udpInDatagrams' => '1.3.6.1.2.1.7.1', + 'udpNoPorts' => '1.3.6.1.2.1.7.2', + 'udpInErrors' => '1.3.6.1.2.1.7.3', + 'udpOutDatagrams' => '1.3.6.1.2.1.7.4', + 'udpTable' => '1.3.6.1.2.1.7.5', + 'udpEntry' => '1.3.6.1.2.1.7.5.1', + 'udpLocalAddress' => '1.3.6.1.2.1.7.5.1.1', + 'udpLocalPort' => '1.3.6.1.2.1.7.5.1.2', + 'egp' => '1.3.6.1.2.1.8', + 'egpInMsgs' => '1.3.6.1.2.1.8.1', + 'egpInErrors' => '1.3.6.1.2.1.8.2', + 'egpOutMsgs' => '1.3.6.1.2.1.8.3', + 'egpOutErrors' => '1.3.6.1.2.1.8.4', + 'egpNeighTable' => '1.3.6.1.2.1.8.5', + 'egpNeighEntry' => '1.3.6.1.2.1.8.5.1', + 'egpNeighState' => '1.3.6.1.2.1.8.5.1.1', + 'egpNeighStateUps' => '1.3.6.1.2.1.8.5.1.10', + 'egpNeighStateDowns' => '1.3.6.1.2.1.8.5.1.11', + 'egpNeighIntervalHello' => '1.3.6.1.2.1.8.5.1.12', + 'egpNeighIntervalPoll' => '1.3.6.1.2.1.8.5.1.13', + 'egpNeighMode' => '1.3.6.1.2.1.8.5.1.14', + 'egpNeighEventTrigger' => '1.3.6.1.2.1.8.5.1.15', + 'egpNeighAddr' => '1.3.6.1.2.1.8.5.1.2', + 'egpNeighAs' => '1.3.6.1.2.1.8.5.1.3', + 'egpNeighInMsgs' => '1.3.6.1.2.1.8.5.1.4', + 'egpNeighInErrs' => '1.3.6.1.2.1.8.5.1.5', + 'egpNeighOutMsgs' => '1.3.6.1.2.1.8.5.1.6', + 'egpNeighOutErrs' => '1.3.6.1.2.1.8.5.1.7', + 'egpNeighInErrMsgs' => '1.3.6.1.2.1.8.5.1.8', + 'egpNeighOutErrMsgs' => '1.3.6.1.2.1.8.5.1.9', + 'egpAs' => '1.3.6.1.2.1.8.6', + 'transmission' => '1.3.6.1.2.1.10', + 'frame-relay' => '1.3.6.1.2.1.10.32', + 'frDlcmiTable' => '1.3.6.1.2.1.10.32.1', + 'frDlcmiEntry' => '1.3.6.1.2.1.10.32.1.1', + 'frDlcmiIfIndex' => '1.3.6.1.2.1.10.32.1.1.1', + 'frDlcmiState' => '1.3.6.1.2.1.10.32.1.1.2', + 'frDlcmiAddress' => '1.3.6.1.2.1.10.32.1.1.3', + 'frDlcmiAddressLen' => '1.3.6.1.2.1.10.32.1.1.4', + 'frDlcmiPollingInterval' => '1.3.6.1.2.1.10.32.1.1.5', + 'frDlcmiFullEnquiryInterval' => '1.3.6.1.2.1.10.32.1.1.6', + 'frDlcmiErrorThreshold' => '1.3.6.1.2.1.10.32.1.1.7', + 'frDlcmiMonitoredEvents' => '1.3.6.1.2.1.10.32.1.1.8', + 'frDlcmiMaxSupportedVCs' => '1.3.6.1.2.1.10.32.1.1.9', + 'frDlcmiMulticast' => '1.3.6.1.2.1.10.32.1.1.10', + 'frCircuitTable' => '1.3.6.1.2.1.10.32.2', + 'frCircuitEntry' => '1.3.6.1.2.1.10.32.2.1', + 'frCircuitIfIndex' => '1.3.6.1.2.1.10.32.2.1.1', + 'frCircuitDlci' => '1.3.6.1.2.1.10.32.2.1.2', + 'frCircuitState' => '1.3.6.1.2.1.10.32.2.1.3', + 'frCircuitReceivedFECNs' => '1.3.6.1.2.1.10.32.2.1.4', + 'frCircuitReceivedBECNs' => '1.3.6.1.2.1.10.32.2.1.5', + 'frCircuitSentFrames' => '1.3.6.1.2.1.10.32.2.1.6', + 'frCircuitSentOctets' => '1.3.6.1.2.1.10.32.2.1.7', + 'frOutOctets' => '1.3.6.1.2.1.10.32.2.1.7', + 'frCircuitReceivedFrames' => '1.3.6.1.2.1.10.32.2.1.8', + 'frCircuitReceivedOctets' => '1.3.6.1.2.1.10.32.2.1.9', + 'frInOctets' => '1.3.6.1.2.1.10.32.2.1.9', + 'frCircuitCreationTime' => '1.3.6.1.2.1.10.32.2.1.10', + 'frCircuitLastTimeChange' => '1.3.6.1.2.1.10.32.2.1.11', + 'frCircuitCommittedBurst' => '1.3.6.1.2.1.10.32.2.1.12', + 'frCircuitExcessBurst' => '1.3.6.1.2.1.10.32.2.1.13', + 'frCircuitThroughput' => '1.3.6.1.2.1.10.32.2.1.14', + 'frErrTable' => '1.3.6.1.2.1.10.32.3', + 'frErrEntry' => '1.3.6.1.2.1.10.32.3.1', + 'frErrIfIndex' => '1.3.6.1.2.1.10.32.3.1.1', + 'frErrType' => '1.3.6.1.2.1.10.32.3.1.2', + 'frErrData' => '1.3.6.1.2.1.10.32.3.1.3', + 'frErrTime' => '1.3.6.1.2.1.10.32.3.1.4', + 'frame-relay-globals' => '1.3.6.1.2.1.10.32.4', + 'frTrapState' => '1.3.6.1.2.1.10.32.4.1', + 'snmp' => '1.3.6.1.2.1.11', + 'snmpInPkts' => '1.3.6.1.2.1.11.1', + 'snmpInBadValues' => '1.3.6.1.2.1.11.10', + 'snmpInReadOnlys' => '1.3.6.1.2.1.11.11', + 'snmpInGenErrs' => '1.3.6.1.2.1.11.12', + 'snmpInTotalReqVars' => '1.3.6.1.2.1.11.13', + 'snmpInTotalSetVars' => '1.3.6.1.2.1.11.14', + 'snmpInGetRequests' => '1.3.6.1.2.1.11.15', + 'snmpInGetNexts' => '1.3.6.1.2.1.11.16', + 'snmpInSetRequests' => '1.3.6.1.2.1.11.17', + 'snmpInGetResponses' => '1.3.6.1.2.1.11.18', + 'snmpInTraps' => '1.3.6.1.2.1.11.19', + 'snmpOutPkts' => '1.3.6.1.2.1.11.2', + 'snmpOutTooBigs' => '1.3.6.1.2.1.11.20', + 'snmpOutNoSuchNames' => '1.3.6.1.2.1.11.21', + 'snmpOutBadValues' => '1.3.6.1.2.1.11.22', + 'snmpOutGenErrs' => '1.3.6.1.2.1.11.24', + 'snmpOutGetRequests' => '1.3.6.1.2.1.11.25', + 'snmpOutGetNexts' => '1.3.6.1.2.1.11.26', + 'snmpOutSetRequests' => '1.3.6.1.2.1.11.27', + 'snmpOutGetResponses' => '1.3.6.1.2.1.11.28', + 'snmpOutTraps' => '1.3.6.1.2.1.11.29', + 'snmpInBadVersions' => '1.3.6.1.2.1.11.3', + 'snmpEnableAuthenTraps' => '1.3.6.1.2.1.11.30', + 'snmpInBadCommunityNames' => '1.3.6.1.2.1.11.4', + 'snmpInBadCommunityUses' => '1.3.6.1.2.1.11.5', + 'snmpInASNParseErrs' => '1.3.6.1.2.1.11.6', + 'snmpInTooBigs' => '1.3.6.1.2.1.11.8', + 'snmpInNoSuchNames' => '1.3.6.1.2.1.11.9', + 'ifName' => '1.3.6.1.2.1.31.1.1.1.1', + 'ifInMulticastPkts' => '1.3.6.1.2.1.31.1.1.1.2', + 'ifInBroadcastPkts' => '1.3.6.1.2.1.31.1.1.1.3', + 'ifOutMulticastPkts' => '1.3.6.1.2.1.31.1.1.1.4', + 'ifOutBroadcastPkts' => '1.3.6.1.2.1.31.1.1.1.5', + 'ifHCInOctets' => '1.3.6.1.2.1.31.1.1.1.6', + 'ifHCInUcastPkts' => '1.3.6.1.2.1.31.1.1.1.7', + 'ifHCInMulticastPkts' => '1.3.6.1.2.1.31.1.1.1.8', + 'ifHCInBroadcastPkts' => '1.3.6.1.2.1.31.1.1.1.9', + 'ifHCOutOctets' => '1.3.6.1.2.1.31.1.1.1.10', + 'ifHCOutUcastPkts' => '1.3.6.1.2.1.31.1.1.1.11', + 'ifHCOutMulticastPkts' => '1.3.6.1.2.1.31.1.1.1.12', + 'ifHCOutBroadcastPkts' => '1.3.6.1.2.1.31.1.1.1.13', + 'ifLinkUpDownTrapEnable' => '1.3.6.1.2.1.31.1.1.1.14', + 'ifHighSpeed' => '1.3.6.1.2.1.31.1.1.1.15', + 'ifPromiscuousMode' => '1.3.6.1.2.1.31.1.1.1.16', + 'ifConnectorPresent' => '1.3.6.1.2.1.31.1.1.1.17', + 'ifAlias' => '1.3.6.1.2.1.31.1.1.1.18', + 'ifCounterDiscontinuityTime' => '1.3.6.1.2.1.31.1.1.1.19', + 'experimental' => '1.3.6.1.3', + 'private' => '1.3.6.1.4', + 'enterprises' => '1.3.6.1.4.1', + ); + +# GIL +my %revOIDS = (); # Reversed %SNMP_util::OIDS hash +my $RevNeeded = 1; + +my $agent_start_time = time; + +undef $SNMP_util::Host; +undef $SNMP_util::Session; +undef $SNMP_util::Version; +undef $SNMP_util::LHost; +undef $SNMP_util::IPv4only; +$SNMP_util::Debug = 0; +$SNMP_util::CacheFile = "OID_cache.txt"; +$SNMP_util::CacheLoaded = 0; +$SNMP_util::Return_array_refs = 0; + +srand(time + $$); + +### Prototypes +sub snmpget ($@); +sub snmpgetnext ($@); +sub snmpopen ($$$); +sub snmpwalk ($@); +sub snmpwalk_flg ($$@); +sub snmpset ($@); +sub snmptrap ($$$$$@); +sub snmpgetbulk ($$$@); +sub snmpmaptable ($$@); +sub snmpmaptable4 ($$$@); +sub snmpwalkhash ($$@); +sub toOID (@); +sub snmpmapOID (@); +sub snmpMIB_to_OID ($); +sub encode_oid_with_errmsg ($); +sub Check_OID ($); +sub snmpLoad_OID_Cache ($); +sub snmpQueue_MIB_File (@); + +sub version () { $VERSION; } + +# +# Start an snmp session +# +sub snmpopen ($$$) { + my($host, $type, $vars) = @_; + my($nhost, $port, $community, $lhost, $lport, $nlhost); + my($timeout, $retries, $backoff, $version); + my $v4onlystr; + + $type = 0 if (!defined($type)); + $community = "public"; + $nlhost = ""; + + ($community, $host) = ($1, $2) if ($host =~ /^(.*)@([^@]+)$/); + + # We can't split on the : character because a numeric IPv6 + # address contains a variable number of :'s + my $opts; + if( ($host =~ /^(\[.*\]):(.*)$/) || ($host =~ /^(\[.*\])$/) ) { + # Numeric IPv6 address between [] + ($host, $opts) = ($1, $2); + } else { + # Hostname or numeric IPv4 address + ($host, $opts) = split(':', $host, 2); + } + ($port, $timeout, $retries, $backoff, $version, $v4onlystr) = split(':', $opts, 6) + if(defined($opts) && (length $opts > 0) ); + + undef($version) if (defined($version) && length($version) <= 0); + $v4onlystr = "" unless defined $v4onlystr; + $version = '1' unless defined $version; + if (defined($port) && ($port =~ /^([^!]*)!(.*)$/)) { + ($port, $lhost) = ($1, $2); + $nlhost = $lhost; + ($lhost, $lport) = ($1, $2) if ($lhost =~ /^(.*)!(.*)$/); + undef($lhost) if (defined($lhost) && (length($lhost) <= 0)); + undef($lport) if (defined($lport) && (length($lport) <= 0)); + } + undef($port) if (defined($port) && length($port) <= 0); + $port = 162 if ($type == 1 && !defined($port)); + $nhost = "$community\@$host"; + $nhost .= ":" . $port if (defined($port)); + + if ((!defined($SNMP_util::Session)) + || ($SNMP_util::Host ne $nhost) + || ($SNMP_util::Version ne $version) + || ($SNMP_util::LHost ne $nlhost) + || ($SNMP_util::IPv4only ne $v4onlystr)) { + if (defined($SNMP_util::Session)) { + $SNMP_util::Session->close(); + undef $SNMP_util::Session; + undef $SNMP_util::Host; + undef $SNMP_util::Version; + undef $SNMP_util::LHost; + undef $SNMP_util::IPv4only; + } + $SNMP_util::Session = ($version =~ /^2c?$/i) + ? SNMPv2c_Session->open($host, $community, $port, undef, + $lport, undef, $lhost, ($v4onlystr eq 'v4only') ? 1:0 ) + : SNMP_Session->open($host, $community, $port, undef, + $lport, undef, $lhost, ($v4onlystr eq 'v4only') ? 1:0 ); + ($SNMP_util::Host = $nhost, $SNMP_util::Version = $version, + $SNMP_util::LHost = $nlhost, $SNMP_util::IPv4only = $v4onlystr) if defined($SNMP_util::Session); + } + + if (defined($SNMP_util::Session)) { + if (ref $vars->[0] eq 'HASH') { + my $opts = shift @$vars; + foreach $type (keys %$opts) { + if ($type eq 'return_array_refs') { + $SNMP_util::Return_array_refs = $opts->{$type}; + } + else { + if (exists $SNMP_util::Session->{$type}) { + if ($type eq 'timeout') { + $SNMP_util::Session->set_timeout($opts->{$type}); + } elsif ($type eq 'retries') { + $SNMP_util::Session->set_retries($opts->{$type}); + } elsif ($type eq 'backoff') { + $SNMP_util::Session->set_backoff($opts->{$type}); + } else { + $SNMP_util::Session->{$type} = $opts->{$type}; + } + } else { + carp "SNMPopen Unknown SNMP Option Key '$type'\n" + unless ($SNMP_Session::suppress_warnings > 1); + } + } + } + } + $SNMP_util::Session->set_timeout($timeout) + if (defined($timeout) && (length($timeout) > 0)); + $SNMP_util::Session->set_retries($retries) + if (defined($retries) && (length($retries) > 0)); + $SNMP_util::Session->set_backoff($backoff) + if (defined($backoff) && (length($backoff) > 0)); + } + return $SNMP_util::Session; +} + + +# +# A restricted snmpget. +# +sub snmpget ($@) { + my($host, @vars) = @_; + my(@enoid, $var, $response, $bindings, $binding, $value, $oid, @retvals); + my $session; + + $session = &snmpopen($host, 0, \@vars); + if (!defined($session)) { + carp "SNMPGET Problem for $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } + + @enoid = &toOID(@vars); + return undef unless defined $enoid[0]; + + if ($session->get_request_response(@enoid)) { + $response = $session->pdu_buffer; + ($bindings) = $session->decode_get_response($response); + while ($bindings) { + ($binding, $bindings) = decode_sequence($bindings); + ($oid, $value) = decode_by_template($binding, "%O%@"); + my $tempo = pretty_print($value); + push @retvals, $tempo; + } + return(@retvals); + } + $var = join(' ', @vars); + carp "SNMPGET Problem for $var on $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; +} + +# +# A restricted snmpgetnext. +# +sub snmpgetnext ($@) { + my($host, @vars) = @_; + my(@enoid, $var, $response, $bindings, $binding); + my($value, $upoid, $oid, @retvals); + my($noid); + my $session; + + $session = &snmpopen($host, 0, \@vars); + if (!defined($session)) { + carp "SNMPGETNEXT Problem for $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } + + @enoid = &toOID(@vars); + return undef unless defined $enoid[0]; + + undef @vars; + undef @retvals; + foreach $noid (@enoid) { + $upoid = pretty_print($noid); + push(@vars, $upoid); + } + if ($session->getnext_request_response(@enoid)) { + $response = $session->pdu_buffer; + ($bindings) = $session->decode_get_response($response); + while ($bindings) { + ($binding, $bindings) = decode_sequence($bindings); + ($oid, $value) = decode_by_template($binding, "%O%@"); + my $tempo = pretty_print($oid); + my $tempv = pretty_print($value); + push @retvals, "$tempo:$tempv"; + } + return (@retvals); + } else { + $var = join(' ', @vars); + carp "SNMPGETNEXT Problem for $var on $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } +} + +# +# A restricted snmpwalk. +# +sub snmpwalk ($@) { + my($host, @vars) = @_; + return(&snmpwalk_flg($host, undef, @vars)); +} + +# +# Walk the MIB, putting everything you find into hashes. +# +sub snmpwalkhash($$@) { +# my($host, $hash_sub, @vars) = @_; + return(&snmpwalk_flg( @_ )); +} + +sub snmpwalk_flg ($$@) { + my($host, $hash_sub, @vars) = @_; + my(@enoid, $var, $response, $bindings, $binding); + my($value, $upoid, $oid, @retvals, @retvaltmprefs); + my($got, @nnoid, $noid, $ok, $ix, @avars); + my $session; + my(%soid); + my(%done, %rethash); + + $session = &snmpopen($host, 0, \@vars); + if (!defined($session)) { + carp "SNMPWALK Problem for $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } + + @enoid = toOID(@vars); + return undef unless defined $enoid[0]; + + # GIL + # + # Create/Refresh a reversed hash with oid -> name + # + if (defined($hash_sub) && $RevNeeded) { + %revOIDS = reverse %SNMP_util::OIDS; + $RevNeeded = 0; + } + + $got = 0; + @nnoid = @enoid; + undef @vars; + foreach $noid (@enoid) { + $upoid = pretty_print($noid); + push(@vars, $upoid); + } + + # @vars is the original set of walked variables. + # @avars is the current set of walked variables as the + # walk goes on. + # @vars stays static while @avars may shrink as we reach end + # of walk for individual variables during PDU exchange. + + @avars = @vars; + + # IlvJa + # + # Create temporary array of refs to return vals. + + if ($SNMP_util::Return_array_refs) { + for($ix = 0;$ix < scalar @vars; $ix++) { + my $tmparray = []; + $retvaltmprefs[$ix] = $tmparray; + $retvals[$ix] = $tmparray; + } + } + + + while(($SNMP_util::Version ne '1' && $session->{'use_getbulk'}) + ? $session->getbulk_request_response(0, + $session->default_max_repetitions(), + @nnoid) + : $session->getnext_request_response(@nnoid)) + { + $got = 1; + $response = $session->pdu_buffer; + ($bindings) = $session->decode_get_response($response); + $ix = 0; + while ($bindings) { + ($binding, $bindings) = decode_sequence($bindings); + unless ($nnoid[$ix]) { # IlvJa + $ix = ++$ix % (scalar @avars); + next; + } + ($oid, $value) = decode_by_template($binding, "%O%@"); + $ok = 0; + my $tempo = pretty_print($oid); + $noid = $avars[$ix]; # IlvJa + if ($tempo =~ /^$noid\./ || $tempo eq $noid ) { + $ok = 1; + $upoid = $noid; + } else { + # IlvJa + # + # The walk for variable $var[$ix] has been finished as + # $nnoid[$ix] no longer is in the $avar[$ix] OID tree. + # So we exclude this variable from further requests. + + $avars[$ix] = ""; + $nnoid[$ix] = ""; + $retvaltmprefs[$ix] = undef if $SNMP_util::Return_array_refs; + } + if ($ok) { + my $tmp = encode_oid_with_errmsg ($tempo); + return undef unless defined $tmp; + next if (exists($done{$tmp})); # GIL + $nnoid[$ix] = $tmp; # Keep on walking. (IlvJa) + my $tempv = pretty_print($value); + if (defined($hash_sub)) { + # + # extract name of the oid, if possible, the rest becomes the instance + # + my $inst = ""; + my $upo = $upoid; + while (!exists($revOIDS{$upo}) && length($upo)) { + $upo =~ s/(\.\d+?)$//; + if (defined($1) && length($1)) { + $inst = $1 . $inst; + } else { + $upo = ""; + last; + } + } + if (length($upo) && exists($revOIDS{$upo})) { + $upo = $revOIDS{$upo} . $inst; + } else { + $upo = $upoid; + } + + $inst = ""; + while (!exists($revOIDS{$tempo}) && length($tempo)) { + $tempo =~ s/(\.\d+?)$//; + if (defined($1) && length($1)) { + $inst = $1 . $inst; + } else { + $tempo = ""; + last; + } + } + if (length($tempo) && exists($revOIDS{$tempo})) { + $tempo = $revOIDS{$tempo} . $inst; + } else { + $tempo = pretty_print($oid); + } + # + # call hash_sub + # + &$hash_sub(\%rethash, $host, $revOIDS{$tempo}, $tempo, $inst, + $tempv, $upo); + } else { + if ($SNMP_util::Return_array_refs) { + $tempo=~s/^$upoid\.//; + push @{$retvaltmprefs[$ix]}, "$tempo:$tempv"; + } else { + $tempo=~s/^$upoid\.// if ($#enoid <= 0); + push @retvals, "$tempo:$tempv"; + } + } + $done{$tmp} = 1; # GIL + } + $ix = ++$ix % (scalar @avars); + } + + # Ok, @nnoid should contain the remaining variables for the + # next request. Some or all entries in @nnoid might be the empty + # string. If the nth element in @nnoid is "" that means that + # the walk related to the nth variable in the last request has been + # completed and we should not include that var in subsequent reqs. + + # Clean up both @nnoid and @avars so "" elements are removed. + @nnoid = grep (($_), @nnoid); + @avars = grep (($_), @avars); + @retvaltmprefs = grep (($_), @retvaltmprefs); + + last if ($#nnoid < 0); # @nnoid empty means we are done walking. + } + if ($got) { + if (defined($hash_sub)) { + return (%rethash) + } else { + return (@retvals); + } + } else { + $var = join(' ', @vars); + carp "SNMPWALK Problem for $var on $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } +} + +# +# A restricted snmpset. +# +sub snmpset($@) { + my($host, @vars) = @_; + my(@enoid, $response, $bindings, $binding); + my($oid, @retvals, $type, $value); + my $session; + + $session = &snmpopen($host, 0, \@vars); + if (!defined($session)) { + carp "SNMPSET Problem for $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } + + while(@vars) { + ($oid) = toOID((shift @vars)); + $type = shift @vars; + $value = shift @vars; + if ($type =~ /string/i) { + $value = encode_string($value); + push @enoid, [$oid,$value]; + } elsif ($type =~ /ipaddr/i) { + $value = encode_ip_address($value); + push @enoid, [$oid,$value]; + } elsif ($type =~ /int/i) { + $value = encode_int($value); + push @enoid, [$oid,$value]; + } elsif ($type =~ /oid/i) { + my $tmp = encode_oid_with_errmsg($value); + return undef unless defined $tmp; + push @enoid, [$oid,$tmp]; + } elsif ($type =~ /timeticks/i) { + $value = encode_timeticks($value); + push @enoid, [$oid,$value]; + } else { + carp "unknown SNMP type: $type\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } + } + return undef unless defined $enoid[0]; + if ($session->set_request_response(@enoid)) { + $response = $session->pdu_buffer; + ($bindings) = $session->decode_get_response($response); + while ($bindings) { + ($binding, $bindings) = decode_sequence($bindings); + ($oid, $value) = decode_by_template($binding, "%O%@"); + my $tempo = pretty_print($value); + push @retvals, $tempo; + } + return (@retvals); + } + return undef; +} + +# +# Send an SNMP trap +# +sub snmptrap($$$$$@) { + my($host, $ent, $agent, $gen, $spec, @vars) = @_; + my($oid, @retvals, $type, $value); + my(@enoid); + my $session; + + $session = &snmpopen($host, 1, \@vars); + if (!defined($session)) { + carp "SNMPTRAP Problem for $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } + + if ($agent =~ /^\d+\.\d+\.\d+\.\d+(.*)/ ) { + $agent = pack("C*", split /\./, $agent); + } else { + $agent = inet_aton($agent); + } + push @enoid, toOID(($ent)); + push @enoid, encode_ip_address($agent); + push @enoid, encode_int($gen); + push @enoid, encode_int($spec); + push @enoid, encode_timeticks((time-$agent_start_time) * 100); + while(@vars) { + ($oid) = toOID((shift @vars)); + $type = shift @vars; + $value = shift @vars; + if ($type =~ /string/i) { + $value = encode_string($value); + push @enoid, [$oid,$value]; + } elsif ($type =~ /ipaddr/i) { + $value = encode_ip_address($value); + push @enoid, [$oid,$value]; + } elsif ($type =~ /int/i) { + $value = encode_int($value); + push @enoid, [$oid,$value]; + } elsif ($type =~ /oid/i) { + my $tmp = encode_oid_with_errmsg($value); + return undef unless defined $tmp; + push @enoid, [$oid,$tmp]; + } else { + carp "unknown SNMP type: $type\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } + } + return($session->trap_request_send(@enoid)); +} + +# +# A restricted snmpgetbulk. +# +sub snmpgetbulk ($$$@) { + my($host, $nr, $mr, @vars) = @_; + my(@enoid, $var, $response, $bindings, $binding); + my($value, $upoid, $oid, @retvals); + my($noid); + my $session; + + $session = &snmpopen($host, 0, \@vars); + if (!defined($session)) { + carp "SNMPGETBULK Problem for $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } + + @enoid = &toOID(@vars); + return undef unless defined $enoid[0]; + + undef @vars; + undef @retvals; + foreach $noid (@enoid) { + $upoid = pretty_print($noid); + push(@vars, $upoid); + } + if ($session->getbulk_request_response($nr, $mr, @enoid)) { + $response = $session->pdu_buffer; + ($bindings) = $session->decode_get_response($response); + while ($bindings) { + ($binding, $bindings) = decode_sequence($bindings); + ($oid, $value) = decode_by_template($binding, "%O%@"); + my $tempo = pretty_print($oid); + my $tempv = pretty_print($value); + push @retvals, "$tempo:$tempv"; + } + return (@retvals); + } else { + $var = join(' ', @vars); + carp "SNMPGETBULK Problem for $var on $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } +} + +# +# walk a table, calling a user-supplied function for each +# column of a table. +# +sub snmpmaptable($$@) { + my($host, $fun, @vars) = @_; + return snmpmaptable4($host, $fun, 0, @vars); +} + +sub snmpmaptable4($$$@) { + my($host, $fun, $max_reps, @vars) = @_; + my(@enoid, $var, $session); + + $session = &snmpopen($host, 0, \@vars); + if (!defined($session)) { + carp "SNMPMAPTABLE Problem for $host\n" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } + + foreach $var (toOID(@vars)) { + push(@enoid, [split('\.', pretty_print($var))]); + } + + $max_reps = $session->default_max_repetitions() if ($max_reps <= 0); + + return $session->map_table_start_end( [@enoid], + sub() { + my ($ind, @vals) = @_; + my (@pvals, $val); + + foreach $val (@vals) { + push(@pvals, pretty_print($val)); + } + &$fun($ind, @pvals); + }, + "", undef, $max_reps); +} + + +# +# Given an OID in either ASN.1 or mixed text/ASN.1 notation, return an +# encoded OID. +# +sub toOID(@) { + my(@vars) = @_; + my($oid, $var, $tmp, $tmpv, @retvar); + + undef @retvar; + foreach $var (@vars) { + ($oid, $tmp) = &Check_OID($var); + if (!$oid && $SNMP_util::CacheLoaded == 0) { + $tmp = $SNMP_Session::suppress_warnings; + $SNMP_Session::suppress_warnings = 1000; + + &snmpLoad_OID_Cache($SNMP_util::CacheFile); + + $SNMP_util::CacheLoaded = 1; + $SNMP_Session::suppress_warnings = $tmp; + + ($oid, $tmp) = &Check_OID($var); + } + while (!$oid && $#SNMP_util::MIB_Files >= 0) { + $tmp = $SNMP_Session::suppress_warnings; + $SNMP_Session::suppress_warnings = 1000; + + snmpMIB_to_OID(shift(@SNMP_util::MIB_Files)); + + $SNMP_Session::suppress_warnings = $tmp; + + ($oid, $tmp) = &Check_OID($var); + if ($oid) { + open(CACHE, ">>$SNMP_util::CacheFile"); + print CACHE "$tmp\t$oid\n"; + close(CACHE); + } + } + if ($oid) { + $var =~ s/^$tmp/$oid/; + } else { + carp "Unknown SNMP var $var\n" + unless ($SNMP_Session::suppress_warnings > 1); + next; + } + while ($var =~ /\"([^\"]*)\"/) { + $tmp = sprintf("%d.%s", length($1), join(".", map(ord, split(//, $1)))); + $var =~ s/\"$1\"/$tmp/; + } + print "toOID: $var\n" if $SNMP_util::Debug; + $tmp = encode_oid_with_errmsg($var); + return undef unless defined $tmp; + push(@retvar, $tmp); + } + return @retvar; +} + +# +# Add passed-in text, OID pairs to the OID mapping table. +# +sub snmpmapOID(@) +{ + my(@vars) = @_; + my($oid, $txt, $ind); + + $ind = 0; + while($ind <= $#vars) { + $txt = $vars[$ind++]; + next unless($txt =~ /^(([a-zA-Z][a-zA-Z\d\-]*\.)*([a-zA-Z][a-zA-Z\d\-]*))$/); + + $oid = $vars[$ind++]; + next unless($oid =~ /^((\d+.)*\d+)$/); + + $SNMP_util::OIDS{$txt} = $oid; + $RevNeeded = 1; + print "snmpmapOID: $txt => $oid\n" if $SNMP_util::Debug; + } + + return undef; +} + +# +# Open the passed-in file name and read it in to populate +# the cache of text-to-OID map table. It expects lines +# with two fields, the first the textual string like "ifInOctets", +# and the second the OID value, like "1.3.6.1.2.1.2.2.1.10". +# +# blank lines and anything after a '#' or between '--' is ignored. +# +sub snmpLoad_OID_Cache ($) { + my($arg) = @_; + my($txt, $oid); + + if (!open(CACHE, $arg)) { + carp "snmpLoad_OID_Cache: Can't open $arg: $!" + unless ($SNMP_Session::suppress_warnings > 1); + return -1; + } + + while(<CACHE>) { + s/#.*//; + s/--.*--//g; + s/--.*//; + next if (/^$/); + next unless (/\s/); + chop; + ($txt, $oid) = split(' ', $_, 2); + &snmpmapOID($txt, $oid); + } + close(CACHE); + return 0; +} + +# +# Check to see if an OID is in the text-to-OID cache. +# Returns the OID and the corresponding text as two separate +# elements. +# +sub Check_OID ($) { + my($var) = @_; + my($tmp, $tmpv, $oid); + + if ($var =~ /^(([a-zA-Z][a-zA-Z\d\-]*\.)*([a-zA-Z][a-zA-Z\d\-]*))/) + { + $tmp = $&; + $tmpv = $tmp; + for (;;) { + last if defined($SNMP_util::OIDS{$tmpv}); + last if !($tmpv =~ s/^[^\.]*\.//); + } + $oid = $SNMP_util::OIDS{$tmpv}; + if ($oid) { + return ($oid, $tmp); + } else { + return undef; + } + } + return ($var, $var); +} + +# +# Save the passed-in list of MIB files until an OID can't be +# found in the existing table. At that time the MIB file will +# be loaded, and the lookup attempted again. +# +sub snmpQueue_MIB_File (@) { + my(@files) = @_; + my($file); + + foreach $file (@files) { + push(@SNMP_util::MIB_Files, $file); + } +} + +# +# Read in the passed MIB file, parsing it +# for their text-to-OID mappings +# +sub snmpMIB_to_OID ($) { + my($arg) = @_; + my($quote, $buf, $var, $code, $val, $tmp, $tmpv, $strt); + my($ret, $pass, $pos, $need2pass, $cnt, %prev); + my(%Link) = ( + 'org' => 'iso', + 'dod' => 'org', + 'internet' => 'dod', + 'directory' => 'internet', + 'mgmt' => 'internet', + 'mib-2' => 'mgmt', + 'experimental' => 'internet', + 'private' => 'internet', + 'enterprises' => 'private', + ); + + if (!open(MIB, $arg)) { + carp "snmpMIB_to_OID: Can't open $arg: $!" + unless ($SNMP_Session::suppress_warnings > 1); + return -1; + } + print "snmpMIB_to_OID: loading $arg\n" if $SNMP_util::Debug; + $ret = 0; + $pass = 0; + $need2pass = 1; + $cnt = 0; + $pos = tell(MIB); + while($need2pass) { + while(<MIB>) { + s/--.*--//g; # throw away comments (-- anything --) + s/--.*//; # throw away comments (-- anything EOL) + if ($quote) { + next unless /"/; + $quote = 0; + } + chop; +# +# $buf = "$buf $_"; +# Previous line removed (and following replacement) +# suggested by Brian Reichert, reichert@numachi.com +# + $buf .= ' ' . $_; + $buf =~ s/\s+/ /g; + + if ($buf =~ / DEFINITIONS ::= BEGIN/) { + if ($pass == 0 && $need2pass) { + seek(MIB, $pos, 0); + $buf = ""; + $pass = 1; + $need2pass = 0; + $cnt = 0; + next; + } + $need2pass = 0; + $pass = 0; + $pos = tell(MIB); + undef %Link; + undef %prev; + %Link = ( + 'org' => 'iso', + 'dod' => 'org', + 'internet' => 'dod', + 'directory' => 'internet', + 'mgmt' => 'internet', + 'mib-2' => 'mgmt', + 'experimental' => 'internet', + 'private' => 'internet', + 'enterprises' => 'private', + ); + $buf = ""; + next; + } + + $buf =~ s/OBJECT-TYPE/OBJECT IDENTIFIER/; + $buf =~ s/OBJECT-IDENTITY/OBJECT IDENTIFIER/; + $buf =~ s/OBJECT-GROUP/OBJECT IDENTIFIER/; + $buf =~ s/MODULE-IDENTITY/OBJECT IDENTIFIER/; + $buf =~ s/ IMPORTS .*\;//; + $buf =~ s/ SEQUENCE {.*}//; + $buf =~ s/ SYNTAX .*//; + $buf =~ s/ [\w-]+ ::= OBJECT IDENTIFIER//; + $buf =~ s/ OBJECT IDENTIFIER .* ::= {/ OBJECT IDENTIFIER ::= {/; + $buf =~ s/".*"//; + if ($buf =~ /"/) { + $quote = 1; + } + + if ($buf =~ / ([\w\-]+) OBJECT IDENTIFIER ::= {([^}]+)}/) { + $var = $1; + $buf = $2; + undef $val; + $buf =~ s/ +$//; + ($code, $val) = split(' ', $buf, 2); + + if (!defined($val) || (length($val) <= 0)) { + $SNMP_util::OIDS{$var} = $code; + $cnt++; + print "'$var' => '$code'\n" if $SNMP_util::Debug; + } else { + $strt = $code; + while($val =~ / /) { + ($tmp, $val) = split(' ', $val, 2); + if ($tmp =~ /([\w\-]+)\((\d+)\)/) { + $tmp = $1; + $tmpv = "$SNMP_util::OIDS{$strt}.$2"; + $Link{$tmp} = $strt; + if (!defined($prev{$tmp}) && defined($SNMP_util::OIDS{$tmp})) { + if ($tmpv ne $SNMP_util::OIDS{$tmp}) { + $strt = "$strt.$tmp"; + $SNMP_util::OIDS{$strt} = $tmpv; + $cnt++; + } + } else { + $prev{$tmp} = 1; + $SNMP_util::OIDS{$tmp} = $tmpv; + $cnt++; + $strt = $tmp; + } + } + } + + if (!defined($SNMP_util::OIDS{$strt})) { + if ($pass) { + carp "snmpMIB_to_OID: $arg: \"$strt\" prefix unknown, load the parent MIB first.\n" + unless ($SNMP_Session::suppress_warnings > 1); + } else { + $need2pass = 1; + } + } + $Link{$var} = $strt; + $val = "$SNMP_util::OIDS{$strt}.$val"; + if (!defined($prev{$var}) && defined($SNMP_util::OIDS{$var})) { + if ($val ne $SNMP_util::OIDS{$var}) { + $var = "$strt.$var"; + } + } + + $SNMP_util::OIDS{$var} = $val; + $prev{$var} = 1; + $cnt++; + + print "'$var' => '$val'\n" if $SNMP_util::Debug; + } + undef $buf; + } + } + if ($pass == 0 && $need2pass) { + seek(MIB, $pos, 0); + $buf = ""; + $pass = 1; + $cnt = 0; + } else { + $ret += $cnt; + $need2pass = 0; + } + } + close(MIB); + $RevNeeded = 1; + return $ret; +} + +sub encode_oid_with_errmsg ($) { + my ($oid) = @_; + my $tmp = encode_oid(split(/\./, $oid)); + if (! defined $tmp) { + carp "cannot encode Object ID $oid: $BER::errmsg" + unless ($SNMP_Session::suppress_warnings > 1); + return undef; + } + return $tmp; +} + +1; diff --git a/lib/Smokeping.pm b/lib/Smokeping.pm new file mode 100644 index 0000000..9f66792 --- /dev/null +++ b/lib/Smokeping.pm @@ -0,0 +1,2613 @@ +# -*- perl -*- +package Smokeping; + +use strict; +use CGI; +use Getopt::Long; +use Pod::Usage; +use Digest::MD5 qw(md5_base64); +use SNMP_util; +use SNMP_Session; +use POSIX; +use ISG::ParseConfig; +use RRDs; +use Sys::Syslog qw(:DEFAULT setlogsock); +setlogsock('unix') + if grep /^ $^O $/xo, ("linux", "openbsd", "freebsd", "netbsd"); +use File::Basename; + +# globale persistent variables for speedy +use vars qw($cfg $probes $VERSION $havegetaddrinfo $cgimode); +$VERSION="1.38"; + +# we want opts everywhere +my %opt; + +BEGIN { + $havegetaddrinfo = 0; + eval 'use Socket6'; + $havegetaddrinfo = 1 unless $@; +} + +my $DEFAULTPRIORITY = 'info'; # default syslog priority + +my $logging = 0; # keeps track of whether we have a logging method enabled + +sub do_log(@); +sub load_probe($$$$); + +sub load_probes ($){ + my $cfg = shift; + my %prbs; + foreach my $probe (keys %{$cfg->{Probes}}) { + my @subprobes = grep { ref $cfg->{Probes}{$probe}{$_} eq 'HASH' } keys %{$cfg->{Probes}{$probe}}; + if (@subprobes) { + my $modname = $probe; + my %properties = %{$cfg->{Probes}{$probe}}; + delete @properties{@subprobes}; + for my $subprobe (@subprobes) { + for (keys %properties) { + $cfg->{Probes}{$probe}{$subprobe}{$_} = $properties{$_} + unless exists $cfg->{Probes}{$probe}{$subprobe}{$_}; + } + $prbs{$subprobe} = load_probe($modname, $cfg->{Probes}{$probe}{$subprobe},$cfg, $subprobe); + } + } else { + $prbs{$probe} = load_probe($probe, $cfg->{Probes}{$probe},$cfg, $probe); + } + } + return \%prbs; +}; + +sub load_probe ($$$$) { + my $modname = shift; + my $properties = shift; + my $cfg = shift; + my $name = shift; + $name = $modname unless defined $name; + eval 'require probes::'.$modname; + die "$@\n" if $@; + my $rv; + eval '$rv = probes::'.$modname.'->new( $properties,$cfg,$name);'; + die "$@\n" if $@; + die "Failed to load Probe $name (module $modname)\n" unless defined $rv; + return $rv; +} + +sub snmpget_ident ($) { + my $host = shift; + $SNMP_Session::suppress_warnings = 10; # be silent + my @get = snmpget("${host}::1:1:1", qw(sysContact sysName sysLocation)); + return undef unless @get; + my $answer = join "/", grep { defined } @get; + $answer =~ s/\s+//g; + return $answer; +} + +sub lnk ($$) { + my ($q, $path) = @_; + if ($q->isa('dummyCGI')) { + return $path . ".html"; + } else { + return ($q->script_name() || '') . "?target=" . $path; + } +} + +sub update_dynaddr ($$){ + my $cfg = shift; + my $q = shift; + my @target = split /\./, $q->param('target'); + my $secret = md5_base64($q->param('secret')); + my $address = $ENV{REMOTE_ADDR}; + my $targetptr = $cfg->{Targets}; + foreach my $step (@target){ + return "Error: Unknown Target $step" + unless defined $targetptr->{$step}; + $targetptr = $targetptr->{$step}; + }; + return "Error: Invalid Target" + unless defined $targetptr->{host} and + $targetptr->{host} eq "DYNAMIC/${secret}"; + my $file = $cfg->{General}{datadir}."/".(join "/", @target); + my $prevaddress = "?"; + my $snmp = snmpget_ident $address; + if (-r "$file.adr" and not -z "$file.adr"){ + open(D, "<$file.adr") + or return "Error opening $file.adr: $!\n"; + chomp($prevaddress = <D>); + close D; + } + + if ( $prevaddress ne $address){ + open(D, ">$file.adr.new") + or return "Error writing $file.adr.new: $!"; + print D $address,"\n"; + close D; + rename "$file.adr.new","$file.adr"; + } + if ( $snmp ) { + open (D, ">$file.snmp.new") + or return "Error writing $file.snmp.new: $!"; + print D $snmp,"\n"; + close D; + rename "$file.snmp.new", "$file.snmp"; + } elsif ( -f "$file.snmp") { unlink "$file.snmp" }; + +} +sub sendmail ($$$){ + my $from = shift; + my $to = shift; + $to = $1 if $to =~ /<(.*?)>/; + my $body = shift; + if ($cfg->{General}{mailhost}){ + my $smtp = Net::SMTP->new($cfg->{General}{mailhost}); + $smtp->mail($from); + $smtp->to(split(/\s*,\s*/, $to)); + $smtp->data(); + $smtp->datasend($body); + $smtp->dataend(); + $smtp->quit; + } elsif ($cfg->{General}{sendmail} or -x "/usr/lib/sendmail"){ + open (M, "|-") || exec (($cfg->{General}{sendmail} || "/usr/lib/sendmail"),"-f",$from,$to); + print M $body; + close M; + } +} + +sub sendsnpp ($$){ + my $to = shift; + my $msg = shift; + if ($cfg->{General}{snpphost}){ + my $snpp = Net::SNPP->new($cfg->{General}{snpphost}, Timeout => 60); + $snpp->send( Pager => $to, + Message => $msg) || do_debuglog("ERROR - ". $snpp->message); + $snpp->quit; + } +} + +sub init_alerts ($){ + my $cfg = shift; + foreach my $al (keys %{$cfg->{Alerts}}) { + my $x = $cfg->{Alerts}{$al}; + next unless ref $x eq 'HASH'; + if ($x->{type} eq 'matcher'){ + $x->{pattern} =~ /(\S+)\((.+)\)/ + or die "ERROR: Alert $al pattern entry '$_' is invalid\n"; + my $matcher = $1; + my $arg = $2; + eval 'require matchers::'.$matcher; + die "Matcher '$matcher' could not be loaded: $@\n" if $@; + my $hand; + eval "\$hand = matchers::$matcher->new($arg)"; + die "ERROR: Matcher '$matcher' could not be instantiated\nwith arguments $arg:\n$@\n" if $@; + $x->{length} = $hand->Length; + $x->{sub} = sub { $hand->Test(shift) } ; + } else { + my $sub_front = <<SUB; +sub { + my \$d = shift; + my \$y = \$d->{$x->{type}}; + for(1){ +SUB + my $sub; + my $sub_back = " return 1;\n }\n return 0;\n}\n"; + my @ops = split /\s*,\s*/, $x->{pattern}; + $x->{length} = scalar grep /^[!=><]/, @ops; + my $multis = scalar grep /^[*]/, @ops; + my $it = ""; + for(1..$multis){ + my $ind = " " x ($_-1); + $sub .= <<FOR; +$ind my \$i$_; +$ind for(\$i$_=0; \$i$_<\$imax$_;\$i$_++){ +FOR + }; + my $i = - $x->{length}; + my $incr = 0; + for (@ops) { + my $extra = ""; + $it = " " x $multis; + for(1..$multis){ + $extra .= "-\$i$_"; + }; + /^(==|!=|<|>|<=|>=|\*)(\d+(?:\.\d*)?|U|S|\d*\*)(%?)$/ + or die "ERROR: Alert $al pattern entry '$_' is invalid\n"; + my $op = $1; + my $value = $2; + my $perc = $3; + if ($op eq '*') { + if ($value =~ /^([1-9]\d*)\*$/) { + $value = $1; + $x->{length} += $value; + $sub_front .= " my \$imax$multis = $value;\n"; + $sub_back .= "\n"; + $sub .= <<FOR; +$it last; +$it } +$it return 0 if \$i$multis >= \$imax$multis; +FOR + + $multis--; + next; + } else { + die "ERROR: multi-match operator * must be followed by Number* in Alert $al definition\n"; + } + } elsif ($value eq 'U') { + if ($op eq '==') { + $sub .= "$it next if defined \$y->[$i$extra];\n"; + } elsif ($op eq '!=') { + $sub .= "$it next unless defined \$y->[$i$extra];\n"; + } else { + die "ERROR: invalid operator $op in connection U in Alert $al definition\n"; + } + } elsif ($value eq 'S') { + if ($op eq '==') { + $sub .= "$it next unless defined \$y->[$i$extra] and \$y->[$i$extra] eq 'S';\n"; + } else { + die "ERROR: S is only valid with == operator in Alert $al definition\n"; + } + } elsif ($value eq '*') { + if ($op ne '==') { + die "ERROR: operator $op makes no sense with * in Alert $al definition\n"; + } # do nothing else ... + } else { + if ( $x->{type} eq 'loss') { + die "ERROR: loss should be specified in % (alert $al pattern)\n" unless $perc eq "%"; + } elsif ( $x->{type} eq 'rtt' ) { + $value /= 1000; + } else { + die "ERROR: unknown alert type $x->{type}\n"; + } + $sub .= <<IF; +$it next unless defined \$y->[$i$extra] +$it and \$y->[$i$extra] =~ /^\\d/ +$it and \$y->[$i$extra] $op $value; +IF + } + $i++; + } + $sub_front .= "$it next if scalar \@\$y < $x->{length} ;\n"; + do_debuglog(<<COMP); +### Compiling alert detector pattern '$al' +### $x->{pattern} +$sub_front$sub$sub_back +COMP + $x->{sub} = eval ( $sub_front.$sub.$sub_back ); + die "ERROR: compiling alert pattern $al ($x->{pattern}): $@\n" if $@; + } + } +} + + +sub check_filter ($$) { + my $cfg = shift; + my $name = shift; + # remove the path prefix when filtering and make sure the path again starts with / + my $prefix = $cfg->{General}{datadir}; + $name =~ s|^${prefix}/*|/|; + # if there is a filter do neither schedule these nor make rrds + if ($opt{filter} && scalar @{$opt{filter}}){ + my $ok = 0; + for (@{$opt{filter}}){ + /^\!(.+)$/ && do { + my $rx = $1; + $name !~ /^$rx/ && do{ $ok = 1}; + next; + }; + /^(.+)$/ && do { + my $rx = $1; + $name =~ /^$rx/ && do {$ok = 1}; + next; + }; + } + return $ok; + }; + return 1; +} + +sub init_target_tree ($$$$$$$$); # predeclare recursive subs +sub init_target_tree ($$$$$$$$) { + my $cfg = shift; + my $probes = shift; + my $probe = shift; + my $tree = shift; + my $name = shift; + my $PROBE_CONF = shift; + my $alerts = shift; + my $alertee = shift; + + # inherit probe type from parent + if (not defined $tree->{probe} or $tree->{probe} eq $probe){ + $tree->{probe} = $probe; + # inherit parent values if the probe type has not changed + for (keys %$PROBE_CONF) { + $tree->{PROBE_CONF}{$_} = $PROBE_CONF->{$_} + unless exists $tree->{PROBE_CONF}{$_}; + } + }; + + $tree->{alerts} = $alerts + if not defined $tree->{alerts} and defined $alerts; + + $tree->{alertee} = $alertee + if not defined $tree->{alertee} and defined $alertee; + + if ($tree->{alerts}){ + die "ERROR: no Alerts section\n" + unless exists $cfg->{Alerts}; + $tree->{alerts} = [ split(/\s*,\s*/, $tree->{alerts}) ] unless ref $tree->{alerts} eq 'ARRAY'; + $tree->{fetchlength} = 0; + foreach my $al (@{$tree->{alerts}}) { + die "ERROR: alert $al ($name) is not defined\n" + unless defined $cfg->{Alerts}{$al}; + $tree->{fetchlength} = $cfg->{Alerts}{$al}{length} + if $tree->{fetchlength} < $cfg->{Alerts}{$al}{length}; + } + }; + # fill in menu and title if missing + $tree->{menu} ||= $tree->{host} || "unknown"; + $tree->{title} ||= $tree->{host} || "unknown"; + + foreach my $prop (keys %{$tree}) { + next if $prop eq 'PROBE_CONF'; + if (ref $tree->{$prop} eq 'HASH'){ + if (not -d $name) { + mkdir $name, 0755 or die "ERROR: mkdir $name: $!\n"; + }; + init_target_tree $cfg, $probes, $tree->{probe}, $tree->{$prop}, "$name/$prop", $tree->{PROBE_CONF},$tree->{alerts},$tree->{alertee}; + } + if ($prop eq 'host' and check_filter($cfg,$name)) { + # print "init $name\n"; + die "Error: Invalid Probe: $tree->{probe}" unless defined $probes->{$tree->{probe}}; + my $probeobj = $probes->{$tree->{probe}}; + my $step = $probeobj->step(); + # we have to do the add before calling the _pings method, it won't work otherwise + if($tree->{$prop} =~ /^DYNAMIC/) { + $probeobj->add($tree,$name); + } else { + $probeobj->add($tree,$tree->{$prop}); + } + my $pings = $probeobj->_pings($tree); + + if (not -f $name.".rrd"){ + my @create = + ($name.".rrd", "--step",$step, + "DS:uptime:GAUGE:".(2*$step).":0:U", + "DS:loss:GAUGE:".(2*$step).":0:".$pings, + # 180 Seconds is the max rtt we consider valid ... + "DS:median:GAUGE:".(2*$step).":0:180", + (map { "DS:ping${_}:GAUGE:".(2*$step).":0:180" } + 1..$pings), + (map { "RRA:".(join ":", @{$_}) } @{$cfg->{Database}{_table}} )); + do_debuglog("Calling RRDs::create(@create)"); + RRDs::create(@create); + my $ERROR = RRDs::error(); + do_log "RRDs::create ERROR: $ERROR\n" if $ERROR; + } + } + } +}; + +sub enable_dynamic($$$$); +sub enable_dynamic($$$$){ + my $cfg = shift; + my $cfgfile = $cfg->{__cfgfile}; + my $tree = shift; + my $path = shift; + my $email = ($tree->{email} || shift); + my $print; + die "ERROR: smokemail property in $cfgfile not specified\n" unless defined $cfg->{General}{smokemail}; + die "ERROR: cgiurl property in $cfgfile not specified\n" unless defined $cfg->{General}{cgiurl}; + if (defined $tree->{host} and $tree->{host} eq 'DYNAMIC' ) { + if ( not defined $email ) { + warn "WARNING: No email address defined for $path\n"; + } else { + my $usepath = $path; + $usepath =~ s/\.$//; + my $secret = int(rand 1000000); + my $md5 = md5_base64($secret); + open C, "<$cfgfile" or die "ERROR: Reading $cfgfile: $!\n"; + open G, ">$cfgfile.new" or die "ERROR: Writing $cfgfile.new: $!\n"; + my $section ; + my @goal = split /\./, $usepath; + my $indent = "+"; + my $done; + while (<C>){ + $done && do { print G; next }; + /^\s*\Q*** Targets ***\E\s*$/ && do{$section = 'match'}; + @goal && $section && /^\s*\Q${indent}\E\s*\Q$goal[0]\E/ && do { + $indent .= "+"; + shift @goal; + }; + (not @goal) && /^\s*host\s*=\s*DYNAMIC$/ && do { + print G "host = DYNAMIC/$md5\n"; + $done = 1; + next; + }; + print G; + } + close G; + rename "$cfgfile.new", $cfgfile; + close C; + my $body; + open SMOKE, $cfg->{General}{smokemail} or die "ERROR: can't read $cfg->{General}{smokemail}: $!\n"; + while (<SMOKE>){ + s/<##PATH##>/$usepath/ig; + s/<##SECRET##>/$secret/ig; + s/<##URL##>/$cfg->{General}{cgiurl}/; + s/<##FROM##>/$cfg->{General}{contact}/; + s/<##OWNER##>/$cfg->{General}{owner}/; + s/<##TO##>/$email/; + $body .= $_; + } + close SMOKE; + + + my $mail; + print STDERR "Sending smoke-agent for $usepath to $email ... "; + sendmail $cfg->{General}{contact},$email,$body; + print STDERR "DONE\n"; + } + } + foreach my $prop ( keys %{$tree}) { + next if $prop eq "PROBE_CONF"; + enable_dynamic $cfg, $tree->{$prop},"$path$prop.",$email if ref $tree->{$prop} eq 'HASH'; + } +}; + + +sub target_menu($$$;$); +sub target_menu($$$;$){ + my $tree = shift; + my $open = shift; + my $path = shift; + my $suffix = shift || ''; + my $print; + my $current = shift @{$open} || ""; + + my @hashes; + foreach my $prop (sort { $tree->{$a}{_order} <=> $tree->{$b}{_order}} + grep { ref $tree->{$_} eq 'HASH' and $_ ne "PROBE_CONF" } + keys %{$tree}) { + push @hashes, $prop; + } + return "" unless @hashes; + $print .= "<table width=\"100%\" class=\"menu\" border=\"0\" cellpadding=\"0\" cellspacing=\"0\">\n"; + for (@hashes) { + my $class; + if ($_ eq $current ){ + if ( @$open ) { + $class = 'menuopen'; + } else { + $class = 'menuactive'; + } + } else { + $class = 'menuitem'; + }; + my $menu = $tree->{$_}{menu}; + $menu =~ s/ / /g; + my $menuadd =""; + $menuadd = " " x (20 - length($menu)) if length($menu) < 20; + $print .= "<tr><td class=\"$class\" colspan=\"2\"> - <a class=\"menulink\" HREF=\"$path$_$suffix\">$menu</a>$menuadd</td></tr>\n"; + if ($_ eq $current){ + my $prline = target_menu $tree->{$_}, $open, "$path$_.", $suffix; + $print .= "<tr><td class=\"$class\"> </td><td align=\"left\">$prline</td></tr>" + if $prline; + } + } + $print .= "</table>\n"; + return $print; +}; + + + +sub fill_template ($$){ + my $template = shift; + my $subst = shift; + my $line = $/; + undef $/; + open I, $template or return "<HTML><BODY>ERROR: Reading page template $template: $!</BODY></HTML>"; + my $data = <I>; + close I; + $/ = $line; + foreach my $tag (keys %{$subst}) { + $data =~ s/<##${tag}##>/$subst->{$tag}/g; + } + return $data; +} + +sub exp2seconds ($) { + my $x = shift; + $x =~/(\d+)m/ && return $1*60; + $x =~/(\d+)h/ && return $1*60*60; + $x =~/(\d+)d/ && return $1*60*60*24; + $x =~/(\d+)w/ && return $1*60*60*24*7; + $x =~/(\d+)y/ && return $1*60*60*24*365; + return $x; +} + +sub get_overview ($$$$){ + my $cfg = shift; + my $q = shift; + my $tree = shift; + my $open = shift; + my $dir = ""; + + my $page =""; + + for (@$open) { + $dir .= "/$_"; + mkdir $cfg->{General}{imgcache}.$dir, 0755 + unless -d $cfg->{General}{imgcache}.$dir; + die "ERROR: creating $cfg->{General}{imgcache}$dir: $!\n" + unless -d $cfg->{General}{imgcache}.$dir; + } + my $date = $cfg->{Presentation}{overview}{strftime} ? + POSIX::strftime($cfg->{Presentation}{overview}{strftime}, + localtime(time)) : scalar localtime(time); + foreach my $prop (sort {$tree->{$a}{_order} <=> $tree->{$b}{_order}} + grep { ref $tree->{$_} eq 'HASH' and $_ ne "PROBE_CONF" and defined $tree->{$_}{host}} + keys %$tree) { + my $rrd = $cfg->{General}{datadir}.$dir."/$prop.rrd"; + my $max = $cfg->{Presentation}{overview}{max_rtt} || "100000"; + my $medc = $cfg->{Presentation}{overview}{median_color} || "ff0000"; + my $probe = $probes->{$tree->{$prop}{probe}}; + my $pings = $probe->_pings($tree->{$prop}); + my ($graphret,$xs,$ys) = RRDs::graph + ($cfg->{General}{imgcache}.$dir."/${prop}_mini.png", + '--lazy', + '--start','-'.exp2seconds($cfg->{Presentation}{overview}{range}), + '--title',$tree->{$prop}{title}, + '--height',$cfg->{Presentation}{overview}{height}, + '--width',,$cfg->{Presentation}{overview}{width}, + '--vertical-label',"Seconds", + '--imgformat','PNG', + '--lower-limit','0', + "DEF:median=${rrd}:median:AVERAGE", + "DEF:loss=${rrd}:loss:AVERAGE", + "CDEF:ploss=loss,$pings,/,100,*", + "CDEF:dm=median,0,$max,LIMIT", + "CDEF:dm2=median,1.5,*,0,$max,LIMIT", + "LINE1:dm2", # this is for kicking things down a bit + "LINE1:dm#$medc:median RTT avg\\: ", + "GPRINT:median:AVERAGE: %0.2lf %ss ", + "GPRINT:median:LAST: latest RTT\\: %0.2lf %ss ", + "GPRINT:ploss:AVERAGE: avg pkg loss\\: %.2lf %% ", + "COMMENT: $date\\j"); + my $ERROR = RRDs::error(); + $page .= "<div>"; + if (defined $ERROR) { + $page .= "ERROR: $ERROR"; + } else { + $page.="<A HREF=\"".lnk($q, (join ".", @$open, ${prop}))."\">". + "<IMG BORDER=\"0\" WIDTH=\"$xs\" HEIGHT=\"$ys\" ". + "SRC=\"".$cfg->{General}{imgurl}.$dir."/${prop}_mini.png\"></A>"; + } + $page .="</div>" + } + return $page; +} + +sub findmax ($$) { + my $cfg = shift; + my $rrd = shift; +# my $pings = "ping".int($cfg->{Database}{pings}/1.1); + my %maxmedian; + my @maxmedian; + for (@{$cfg->{Presentation}{detail}{_table}}) { + my ($desc,$start) = @{$_}; + $start = exp2seconds($start); + my ($graphret,$xs,$ys) = RRDs::graph + ("dummy", '--start', -$start, + "DEF:maxping=${rrd}:median:AVERAGE", + 'PRINT:maxping:MAX:%le' ); + my $ERROR = RRDs::error(); + do_log $ERROR if $ERROR; + my $val = $graphret->[0]; + $val = 1 if $val =~ /nan/i; + $maxmedian{$start} = $val; + push @maxmedian, $val; + } + my $med = (sort @maxmedian)[int(($#maxmedian) / 2 )]; + my $max = 0.000001; + foreach my $x ( keys %maxmedian ){ + if ( not defined $cfg->{Presentation}{detail}{unison_tolerance} or ( + $maxmedian{$x} <= $cfg->{Presentation}{detail}{unison_tolerance} * $med + and $maxmedian{$x} >= $med / $cfg->{Presentation}{detail}{unison_tolerance}) ){ + $max = $maxmedian{$x} unless $maxmedian{$x} < $max; + $maxmedian{$x} = undef; + }; + } + foreach my $x ( keys %maxmedian ){ + if (defined $maxmedian{$x}) { + $maxmedian{$x} *= 1.5; + } else { + $maxmedian{$x} = $max * 1.5; + } + + $maxmedian{$x} = $cfg->{Presentation}{detail}{max_rtt} + if $cfg->{Presentation}{detail}{max_rtt} and + $maxmedian{$x} > $cfg->{Presentation}{detail}{max_rtt} + }; + return \%maxmedian; +} + +sub smokecol ($) { + my $count = ( shift )- 2 ; + return [] unless $count > 0; + my $half = $count/2; + my @items; + for (my $i=$count; $i > $half; $i--){ + my $color = int(190/$half * ($i-$half))+50; + push @items, "AREA:cp".($i+2)."#".(sprintf("%02x",$color) x 3); + }; + for (my $i=int($half); $i >= 0; $i--){ + my $color = int(190/$half * ($half - $i))+64; + push @items, "AREA:cp".($i+2)."#".(sprintf("%02x",$color) x 3); + }; + return \@items; +} + +sub get_detail ($$$$){ + my $cfg = shift; + my $q = shift; + my $tree = shift; + my $open = shift; + return "" unless $tree->{host}; + my @dirs = @{$open}; + my $file = pop @dirs; + my $dir = ""; + die "ERROR: ".(join ".", @dirs)." has no probe defined\n" + unless $tree->{probe}; + die "ERROR: ".(join ".", @dirs)." $tree->{probe} is not known\n" + unless $cfg->{__probes}{$tree->{probe}}; + my $probe = $cfg->{__probes}{$tree->{probe}}; + my $ProbeDesc = $probe->ProbeDesc(); + my $step = $probe->step(); + my $pings = $probe->_pings($tree); + + my $page; + + + for (@dirs) { + $dir .= "/$_"; + mkdir $cfg->{General}{imgcache}.$dir, 0755 + unless -d $cfg->{General}{imgcache}.$dir; + die "ERROR: creating $cfg->{General}{imgcache}$dir: $!\n" + unless -d $cfg->{General}{imgcache}.$dir; + + } + my $rrd = $cfg->{General}{datadir}."/".(join "/", @dirs)."/${file}.rrd"; + my $img = $cfg->{General}{imgcache}."/".(join "/", @dirs)."/${file}.rrd"; + + my %lasthight; + if (open (HG,"<${img}.maxhight")){ + while (<HG>){ + chomp; + my @l = split / /; + $lasthight{$l[0]} = $l[1]; + } + close HG; + } + my $max = findmax $cfg, $rrd; + if (open (HG,">${img}.maxhight")){ + foreach my $s (keys %{$max}){ + print HG "$s $max->{$s}\n"; + } + close HG; + } + + my $smoke = $pings - 3 > 0 + ? smokecol $pings : [ 'COMMENT:"Not enough data collected to draw graph"' ]; + my @upargs; + my @upsmoke; + my @median; + my $date = $cfg->{Presentation}{detail}{strftime} ? + POSIX::strftime($cfg->{Presentation}{detail}{strftime}, + localtime(time)) : scalar localtime(time); + + for (@{$cfg->{Presentation}{detail}{_table}}) { + my ($desc,$start) = @{$_}; + $start = exp2seconds($start); + do { + @median = ("DEF:median=${rrd}:median:AVERAGE", + "DEF:loss=${rrd}:loss:AVERAGE", + "CDEF:ploss=loss,$pings,/,100,*", + "GPRINT:median:AVERAGE:Median Ping RTT (avg %.1lf %ss) ", + "LINE1:median#202020" + ); + my $p = $pings; + + my %lc; + my $lastup = 0; + if ( defined $cfg->{Presentation}{detail}{loss_colors}{_table} ) { + for (@{$cfg->{Presentation}{detail}{loss_colors}{_table}}) { + my ($num,$col,$txt) = @{$_}; + $lc{$num} = [ $txt, "#".$col ]; + } + } else { + %lc = (0 => ['0', '#26ff00'], + 1 => ["1/$p", '#00b8ff'], + 2 => ["2/$p", '#0059ff'], + 3 => ["3/$p", '#5e00ff'], + 4 => ["4/$p", '#7e00ff'], + int($p/2) => [int($p/2)."/$p", '#dd00ff'], + $p-1 => [($p-1)."/$p", '#ff0000'], + ); + }; + my $last = -1; + my $swidth = $max->{$start} / $cfg->{Presentation}{detail}{height}; + foreach my $loss (sort {$a <=> $b} keys %lc){ + my $lvar = $loss; $lvar =~ s/\./d/g ; + push @median, + ( + "CDEF:me$lvar=loss,$last,GT,loss,$loss,LE,*,1,UNKN,IF,median,*", + "CDEF:meL$lvar=me$lvar,$swidth,-", + "CDEF:meH$lvar=me$lvar,0,*,$swidth,2,*,+", + "AREA:meL$lvar", + "STACK:meH$lvar$lc{$loss}[1]:$lc{$loss}[0]" + ); + $last = $loss; + } + push @median, ( "GPRINT:ploss:AVERAGE: avg pkg loss\\: %.2lf %%\\l" ); +# map {print "$_<br/>"} @median; + }; + # if we have uptime draw a colorful background or the graph showing the uptime + my $cdir=$cfg->{General}{datadir}."/".(join "/", @dirs)."/"; + if (-f "$cdir/${file}.adr") { + @upsmoke = (); + @upargs = ('COMMENT:Link Up: ', + "DEF:uptime=${rrd}:uptime:AVERAGE", + "CDEF:duptime=uptime,86400,/", + 'GPRINT:duptime:LAST: %0.1lf days ('); + my %upt; + if ( defined $cfg->{Presentation}{detail}{uptime_colors}{_table} ) { + for (@{$cfg->{Presentation}{detail}{uptime_colors}{_table}}) { + my ($num,$col,$txt) = @{$_}; + $upt{$num} = [ $txt, "#".$col]; + } + } else { + %upt = ( 3600 => ['<1h', '#FFD3D3'], + 2*3600 => ['<2h', '#FFE4C7'], + 6*3600 => ['<6h', '#FFF9BA'], + 12*3600 => ['<12h','#F3FFC0'], + 24*3600 => ['<1d', '#E1FFCC'], + 7*24*3600 => ['<1w', '#BBFFCB'], + 30*24*3600 => ['<1m', '#BAFFF5'], + '1e100' => ['>1m', '#DAECFF'] + ); + } + my $lastup = 0; + foreach my $uptime (sort {$a <=> $b} keys %upt){ + push @upargs, + ( + "CDEF:up$uptime=uptime,$lastup,GE,uptime,$uptime,LE,*,INF,UNKN,IF", + "AREA:up$uptime$upt{$uptime}[1]:$upt{$uptime}[0]" + ); + push @upsmoke, + ( + "CDEF:ups$uptime=uptime,$lastup,GE,uptime,$uptime,LE,*,cp2,UNKN,IF", + "AREA:ups$uptime$upt{$uptime}[1]" + ); + $lastup=$uptime; + } + + push @upargs, 'COMMENT:)\l'; +# map {print "$_<br/>"} @upargs; + }; + my @log = (); + push @log, "--logarithmic" if $cfg->{Presentation}{detail}{logarithmic} and + $cfg->{Presentation}{detail}{logarithmic} eq 'yes'; + + my @lazy =(); + @lazy = ('--lazy') if $lasthight{$start} and $lasthight{$start} == $max->{$start}; + my ($graphret,$xs,$ys) = RRDs::graph + ($cfg->{General}{imgcache}.$dir."/${file}_last_${start}.png", + @lazy, + '--start','-'.$start, + '--height',$cfg->{Presentation}{detail}{height}, + '--width',,$cfg->{Presentation}{detail}{width}, + '--title',$desc, + '--rigid', + '--upper-limit', $max->{$start}, + @log, + '--lower-limit',(@log ? ($max->{$start} > 0.01) ? '0.001' : '0.0001' : '0'), + '--vertical-label',"Seconds", + '--imgformat','PNG', + '--color', 'SHADEA#ffffff', + '--color', 'SHADEB#ffffff', + '--color', 'BACK#ffffff', + '--color', 'CANVAS#ffffff', + (map {"DEF:ping${_}=${rrd}:ping${_}:AVERAGE"} 1..$pings), + (map {"CDEF:cp${_}=ping${_},0,$max->{$start},LIMIT"} 1..$pings), + @upargs,# draw the uptime bg color + @$smoke, + @upsmoke, # draw the rest of the uptime bg color + @median, +# 'LINE3:median#ff0000:Median RTT in grey '.$cfg->{Database}{pings}.' pings sorted by RTT', +# 'LINE1:median#ff8080', + # Gray background for times when no data was collected, so they can + # be distinguished from network being down. + ( $cfg->{Presentation}{detail}{nodata_color} ? ( + 'CDEF:nodata=loss,UN,INF,UNKN,IF', + "AREA:nodata#$cfg->{Presentation}{detail}{nodata_color}" ): + ()), + 'HRULE:0#000000', + 'COMMENT:\s', + "COMMENT:Probe: $pings $ProbeDesc every $step seconds", + 'COMMENT:created on '.$date.'\j' ); + + my $ERROR = RRDs::error(); + $page .= "<div>". + ( $ERROR || + "<IMG BORDER=\"0\" WIDTH=\"$xs\" HEIGHT=\"$ys\" ". + "SRC=\"".$cfg->{General}{imgurl}.$dir."/${file}_last_${start}.png\">" )."</div>"; + + } + return $page; +} + +sub display_webpage($$){ + my $cfg = shift; + my $q = shift; + my $open = [ split /\./,( $q->param('target') || '')]; + my $tree = $cfg->{Targets}; + my $step = $cfg->{__probes}{$tree->{probe}}->step(); + for (@$open) { + die "ERROR: Section '$_' does not exist.\n" + unless exists $tree->{$_}; + last unless ref $tree->{$_} eq 'HASH'; + $tree = $tree->{$_}; + } + gen_imgs($cfg); # create logos in imgcache + + print fill_template + ($cfg->{Presentation}{template}, + { + menu => target_menu($cfg->{Targets}, + [@$open], #copy this because it gets changed + ($q->script_name() || '')."?target="), + title => $tree->{title}, + remark => ($tree->{remark} || ''), + overview => get_overview( $cfg,$q,$tree,$open ), + body => get_detail( $cfg,$q,$tree,$open ), + target_ip => ($tree->{host} || ''), + owner => $cfg->{General}{owner}, + contact => $cfg->{General}{contact}, + author => '<A HREF="http://tobi.oetiker.ch/">Tobi Oetiker</A>', + smokeping => '<A HREF="http://people.ee.ethz.ch/~oetiker/webtools/smokeping/counter.cgi/'.$VERSION.'">SmokePing-'.$VERSION.'</A>', + step => $step, + rrdlogo => '<A HREF="http://people.ee.ethz.ch/~oetiker/webtools/rrdtool/"><img border="0" src="'.$cfg->{General}{imgurl}.'/rrdtool.png"></a>', + smokelogo => '<A HREF="http://people.ee.ethz.ch/~oetiker/webtools/smokeping/counter.cgi/'.$VERSION.'"><img border="0" src="'.$cfg->{General}{imgurl}.'/smokeping.png"></a>', + } + ); +} + +# fetch all data. +sub run_probes($$) { + my $probes = shift; + my $justthisprobe = shift; + if (defined $justthisprobe) { + $probes->{$justthisprobe}->ping(); + } else { + foreach my $probe (keys %{$probes}) { + $probes->{$probe}->ping(); + } + } +} + +# report probe status +sub report_probes($$) { + my $probes = shift; + my $justthisprobe = shift; + if (defined $justthisprobe) { + $probes->{$justthisprobe}->report(); + } else { + foreach my $probe (keys %{$probes}){ + $probes->{$probe}->report(); + } + } +} + +sub update_rrds($$$$$$); +sub update_rrds($$$$$$) { + my $cfg = shift; + my $probes = shift; + my $probe = shift; + my $tree = shift; + my $name = shift; + my $justthisprobe = shift; # if defined, update only the targets probed by this probe + + $probe = $tree->{probe} if defined $tree->{probe}; + my $probeobj = $probes->{$probe}; + foreach my $prop (keys %{$tree}) { + + next if $prop eq "PROBE_CONF"; + if (ref $tree->{$prop} eq 'HASH'){ + update_rrds $cfg, $probes, $probe, $tree->{$prop}, $name."/$prop", $justthisprobe; + } + next if defined $justthisprobe and $probe ne $justthisprobe; + if ($prop eq 'host' and check_filter($cfg,$name)) { + #print "update $name\n"; + my $updatestring = $probeobj->rrdupdate_string($tree); + my $pings = $probeobj->_pings($tree); + if ( $tree->{rawlog} ){ + my $file = POSIX::strftime $tree->{rawlog},localtime(time); + if (open LOG,">>$name.$file.csv"){ + print LOG time,"\t",join("\t",split /:/,$updatestring),"\n"; + close LOG; + } else { + do_log "Warning: failed to open $file for logging: $!\n"; + } + } + my @update = ( $name.".rrd", + '--template',(join ":", "uptime", "loss", "median", + map { "ping${_}" } 1..$pings), + "N:".$updatestring + ); + do_debuglog("Calling RRDs::update(@update)"); + RRDs::update ( @update ); + my $ERROR = RRDs::error(); + do_log "RRDs::update ERROR: $ERROR\n" if $ERROR; + # check alerts + # disabled + if ( $tree->{alerts} ) { + $tree->{stack} = {loss=>['S'],rtt=>['S']} unless defined $tree->{stack}; + my $x = $tree->{stack}; + my ($loss,$rtt) = + (split /:/, $probeobj->rrdupdate_string($tree))[1,2]; + $loss = undef if $loss eq 'U'; + my $lossprct = $loss * 100 / $pings; + $rtt = undef if $rtt eq 'U'; + push @{$x->{loss}}, $lossprct; + push @{$x->{rtt}}, $rtt; + if (scalar @{$x->{loss}} > $tree->{fetchlength}){ + shift @{$x->{loss}}; + shift @{$x->{rtt}}; + } + for (@{$tree->{alerts}}) { + if ( not $cfg->{Alerts}{$_} ) { + do_log "WARNING: Empty alert in ".(join ",", @{$tree->{alerts}})." ($name)\n"; + next; + }; + if ( ref $cfg->{Alerts}{$_}{sub} ne 'CODE' ) { + do_log "WARNING: Alert '$_' did not resolve to a Sub Ref. Skipping\n"; + next; + }; + if ( &{$cfg->{Alerts}{$_}{sub}}($x) ){ + # we got a match + my $from; + my $line = "$name/$prop"; + my $base = $cfg->{General}{datadir}; + $line =~ s|^$base/||; + $line =~ s|/host$||; + $line =~ s|/|.|g; + do_log("Alert $_ triggered for $line"); + my $urlline = $line; + $urlline = $cfg->{General}{cgiurl}."?target=".$line; + my $loss = "loss: ".join ", ",map {defined $_ ? (/^\d/ ? sprintf "%.0f%%", $_ :$_):"U" } @{$x->{loss}}; + my $rtt = "rtt: ".join ", ",map {defined $_ ? (/^\d/ ? sprintf "%.0fms", $_*1000 :$_):"U" } @{$x->{rtt}}; + my $stamp = scalar localtime time; + my @to; + foreach my $addr (map {$_ ? (split /\s*,\s*/,$_) : ()} $cfg->{Alerts}{to},$tree->{alertee},$cfg->{Alerts}{$_}{to}){ + next unless $addr; + if ( $addr =~ /^\|(.+)/) { + system $1,$_,$line,$loss,$rtt,$tree->{host}; + } elsif ( $addr =~ /^snpp:(.+)/ ) { + sendsnpp $1, <<SNPPALERT; +$cfg->{Alerts}{$_}{comment} +$_ on $line +$loss +$rtt +SNPPALERT + } else { + push @to, $addr; + } + }; + if (@to){ + my $to = join ",",@to; + sendmail $cfg->{Alerts}{from},$to, <<ALERT; +To: $to +From: $cfg->{Alerts}{from} +Subject: [SmokeAlert] $_ on $line + +$stamp + +Got a match for alert "$_" for $urlline + +Pattern +------- +$cfg->{Alerts}{$_}{pattern} + +Data (old --> now) +------------------ +$loss +$rtt + +Comment +------- +$cfg->{Alerts}{$_}{comment} + + + +ALERT + } + } + } + } + } + } +} + +sub get_parser () { + my $KEY_RE = '[-_0-9a-zA-Z]+'; + my $KEYD_RE = '[-_0-9a-zA-Z.]+'; + my $TARGET = + { + _sections => [ ( "PROBE_CONF", "/$KEY_RE/" ) ], + _vars => [ qw (probe menu title alerts note email host remark rawlog alertee) ], + _order => 1, + _doc => <<DOC, +Each target section can contain information about a host to monitor as +well as further target sections. Most variables have already been +described above. The expression above defines legal names for target +sections. +DOC + alerts => { + _doc => 'Comma separated list of alert names', + _re => '([^\s,]+(,[^\s,]+)*)?', + _re_error => 'Comma separated list of alert names', + }, + host => + { + _doc => <<DOC, +Can either contain the name of a target host or the string B<DYNAMIC>. + +In the second case, the target machine has a dynamic IP address and +thus is required to regularly contact the SmokePing server to verify +its IP address. When starting SmokePing with the commandline argument +B<--email> it will add a secret password to each of the B<DYNAMIC> +host lines and send a script to the owner of each host. This script +must be started regularly on the host in question to make sure +SmokePing monitors the right box. If the target machine supports +SNMP SmokePing will also query the hosts +sysContact, sysName and sysLocation properties to make sure it is +still the same host. +DOC + + _sub => sub { + for ( shift ) { + m|^DYNAMIC| && return undef; + /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/ && return undef; + /^[0-9a-f]{0,4}(\:[0-9a-f]{0,4}){0,6}\:[0-9a-f]{0,4}$/i && return undef; + my $addressfound = 0; + my @tried; + if ($havegetaddrinfo) { + my @ai; + @ai = getaddrinfo( $_, "" ); + unless ($addressfound = scalar(@ai) > 5) { + do_debuglog("WARNING: Hostname '$_' does currently not resolve to an IPv6 address\n"); + @tried = qw{IPv6}; + } + } + unless ($addressfound) { + unless ($addressfound = gethostbyname( $_ )) { + do_debuglog("WARNING: Hostname '$_' does currently not resolve to an IPv4 address\n"); + push @tried, qw{IPv4}; + } + } + unless ($addressfound) { + # do not bomb, as this could be temporary + my $tried = join " or ", @tried; + warn "WARNING: Hostname '$_' does currently not resolve to an $tried address\n" unless $cgimode; + } + return undef; + } + return undef; + }, + }, + email => { _re => '.+\s<\S+@\S+>', + _re_error => + "use an email address of the form 'First Last <em\@ail.kg>'", + _doc => <<DOC, +This is the contact address for the owner of the current host. In connection with the B<DYNAMIC> hosts, +the address will be used for sending the belowmentioned script. +DOC + }, + note => { _doc => <<DOC }, +Some information about this entry which does NOT get displayed on the web. +DOC + rawlog => { _doc => <<DOC, +Log the raw data, gathered for this target, in tab separated format, to a file with the +same basename as the corresponding RRD file. Use posix strftime to format the timestamp to be +put into the file name. The filename is built like this: + + basename.strftime.csv + +Example: + + rawlog=%Y-%m-%d + +this would create a new logfile every day with a name like this: + + targethost.2004-05-03.csv + +DOC + _sub => sub { + eval ( "POSIX::strftime('$_[0]', localtime(time))"); + return $@ if $@; + return undef; + }, + }, + alertee => { _re => '(\|.+|.+@\S+|snpp:)', + _re_error => 'the alertee must be an email address here', + _doc => <<DOC }, +If you want to have alerts for this target and all targets below it go to a particular address +on top of the address already specified in the alert, you can add it here. This can be a comma separated list of items. +DOC + + }; + + $TARGET->{ "/$KEY_RE/" } = $TARGET; + + my $PROBEVARS = { + _vars => [ "/$KEYD_RE/" ], + _doc => <<DOC, +Probe specific variables. +DOC + "/$KEYD_RE/" => { _doc => <<DOC }, +Should be found in the documentation of the +corresponding probe. The values get propagated to those child +nodes using the same Probe. +DOC + }; + + $TARGET->{PROBE_CONF} = $PROBEVARS; + + my $INTEGER_SUB = { + _sub => sub { + return "must be an integer >= 1" + unless $_[ 0 ] == int( $_[ 0 ] ) and $_[ 0 ] >= 1; + return undef; + } + }; + my $DIRCHECK_SUB = { + _sub => sub { + return "Directory '$_[0]' does not exist" unless -d $_[ 0 ]; + return undef; + } + }; + + my $FILECHECK_SUB = { + _sub => sub { + return "File '$_[0]' does not exist" unless -f $_[ 0 ]; + return undef; + } + }; + + my $PROBES = { + _doc => <<DOC, +Each module can take specific configuration information from this area. The jumble of letters above is a regular expression defining legal module names. +DOC + _vars => [ "step", "offset", "pings", "/$KEYD_RE/" ], + "/$KEYD_RE/" => { _doc => 'Each module defines which +variables it wants to accept. So this expression here just defines legal variable names.'}, + "step" => { %$INTEGER_SUB, + _doc => <<DOC }, +Duration of the base interval that this probe should use, if different +from the one specified in the 'Database' section. Note that the step in +the RRD files is fixed when they are originally generated, and if you +change the step parameter afterwards, you'll have to delete the old RRD +files or somehow convert them. (This variable is only applicable if +the variable 'concurrentprobes' is set in the 'General' section.) +DOC + "offset" => { + _re => '(\d+%|random)', + _re_error => + "Use offset either in % of operation interval or 'random'", + _doc => <<DOC }, +If you run many probes concurrently you may want to prevent them from +hitting your network all at the same time. Using the probe-specific +offset parameter you can change the point in time when each probe will +be run. Offset is specified in % of total interval, or alternatively as +'random', and the offset from the 'General' section is used if nothing +is specified here. Note that this does NOT influence the rrds itself, +it is just a matter of when data acqusition is initiated. +(This variable is only applicable if the variable 'concurrentprobes' is set +in the 'General' section.) +DOC + "pings" => { + %$INTEGER_SUB, + _doc => <<DOC}, +How many pings should be sent to each target, if different from the global +value specified in the Database section. Some probes (those derived from +basefork.pm, ie. most except the FPing variants) will even let this be +overridden target-specifically in the PROBE_CONF section (see the +basefork documentation for details). Note that the number of pings in +the RRD files is fixed when they are originally generated, and if you +change this parameter afterwards, you'll have to delete the old RRD +files or somehow convert them. +DOC + }; # $PROBES + + my $PROBESTOP = {}; + %$PROBESTOP = %$PROBES; + $PROBESTOP->{_sections} = ["/$KEY_RE/"]; + $PROBESTOP->{"/$KEY_RE/"} = $PROBES; + for (qw(step offset pings)) { + # we need a deep copy of these + my %h = %{$PROBESTOP->{$_}}; + $PROBES->{$_} = \%h; + delete $PROBES->{$_}{_doc} + } + $PROBES->{_doc} = <<DOC; +You can define multiple instances of the same probe with subsections. +These instances can have different values for their variables, so you +can eg. have one instance of the FPing probe with packet size 1000 and +step 30 and another instance with packet size 64 and step 300. +The name of the subsection determines what the probe will be called, so +you can write descriptive names for the probes. + +If there are any subsections defined, the main section for this probe +will just provide default parameter values for the probe instances, ie. +it will not become a probe instance itself. +DOC + + my $parser = ISG::ParseConfig->new + ( + { + _sections => [ qw(General Database Presentation Probes Alerts Targets) ], + _mandatory => [ qw(General Database Presentation Probes Targets) ], + General => + { + _doc => <<DOC, +General configuration values valid for the whole SmokePing setup. +DOC + _vars => + [ qw(owner imgcache imgurl datadir pagedir piddir sendmail offset + smokemail cgiurl mailhost contact netsnpp + syslogfacility syslogpriority concurrentprobes changeprocessnames) ], + _mandatory => + [ qw(owner imgcache imgurl datadir piddir + smokemail cgiurl contact) ], + imgcache => + { %$DIRCHECK_SUB, + _doc => <<DOC, +A directory which is visible on your webserver where SmokePing can cache graphs. +DOC + }, + + imgurl => + { + _doc => <<DOC, +Either an absolute URL to the B<imgcache> directory or one relative to the directory where you keep the +SmokePing cgi. +DOC + }, + + pagedir => + { + %$DIRCHECK_SUB, + _doc => <<DOC, +Directory to store static representations of pages. +DOC + }, + owner => + { + _doc => <<DOC, +Name of the person responsible for this smokeping installation. +DOC + }, + + mailhost => + { + _doc => <<DOC, +Instead of using sendmail, you can specify the name of an smtp server +and use perl's Net::SMTP module to send mail to DYNAMIC host owners (see below). +DOC + _sub => sub { require Net::SMTP ||return "ERROR: loading Net::SMTP"; return undef; } + }, + snpphost => + { + _doc => <<DOC, +If you have a SNPP (Simple Network Pager Protocol) server at hand, you can have alerts +sent there too. Use the syntax B<snpp:someaddress> to use a snpp address in any place where you can use a mail address otherwhise. +DOC + _sub => sub { require Net::SNPP ||return "ERROR: loading Net::SNPP"; return undef; } + }, + + contact => + { _re => '\S+@\S+', + _re_error => + "use an email address of the form 'name\@place.dom'", + + _doc => <<DOC, +Mail address of the person responsible for this smokeping installation. +DOC + }, + + + datadir => + { + %$DIRCHECK_SUB, + _doc => <<DOC, +The directory where SmokePing can keep its rrd files. +DOC + }, + + piddir => + { + %$DIRCHECK_SUB, + _doc => <<DOC, +The directory where SmokePing keeps its pid when daemonised. +DOC + }, + sendmail => + { + %$FILECHECK_SUB, + _doc => <<DOC, +Path to your sendmail binary. It will be used for sending mails in connection with the support of DYNAMIC addresses. +DOC + }, + smokemail => + { + %$FILECHECK_SUB, + _doc => <<DOC, +Path to the mail template for DYNAMIC hosts. This mail template +must contain keywords of the form B<E<lt>##>I<keyword>B<##E<gt>>. There is a sample +template included with SmokePing. +DOC + }, + cgiurl => + { + _re => 'https?://\S+', + _re_error => + "cgiurl must be a http(s)://.... url", + _doc => <<DOC, +Complete URL path of the SmokePing.cgi +DOC + + }, + syslogfacility => + { + _re => '\w+', + _re_error => + "syslogfacility must be alphanumeric", + _doc => <<DOC, +The syslog facility to use, eg. local0...local7. +Note: syslog logging is only used if you specify this. +DOC + }, + syslogpriority => + { + _re => '\w+', + _re_error => + "syslogpriority must be alphanumeric", + _doc => <<DOC, +The syslog priority to use, eg. debug, notice or info. +Default is $DEFAULTPRIORITY. +DOC + }, + offset => { + _re => '(\d+%|random)', + _re_error => + "Use offset either in % of operation interval or 'random'", + _doc => <<DOC, +If you run many instances of smokeping you may want to prevent them from +hitting your network all at the same time. Using the offset parameter you +can change the point in time when the probes are run. Offset is specified +in % of total interval, or alternatively as 'random'. I recommend to use +'random'. Note that this does NOT influence the rrds itself, it is just a +matter of when data acqusition is initiated. The default offset is 'random'. +DOC + }, + concurrentprobes => { + _re => '(yes|no)', + _re_error =>"this must either be 'yes' or 'no'", + _doc => <<DOC, +If you use multiple probes or multiple instances of the same probe and you +want them to run concurrently in separate processes, set this to 'yes'. This +gives you the possibility to specify probe-specific step and offset parameters +(see the 'Probes' section) for each probe and makes the probes unable to block +each other in cases of service outages. The default is 'yes', but if you for +some reason want the old behaviour you can set this to 'no'. +DOC + }, + changeprocessnames => { + _re => '(yes|no)', + _re_error =>"this must either be 'yes' or 'no'", + _doc => <<DOC, +When using 'concurrentprobes' (see above), this controls whether the probe +subprocesses should change their argv string to indicate their probe in +the process name. If set to 'yes' (the default), the probe name will +be appended to the process name as '[probe]', eg. '/usr/bin/smokeping +[FPing]'. If you don't like this behaviour, set this variable to 'no'. +If 'concurrentprobes' is not set to 'yes', this variable has no effect. +DOC + }, + }, + Database => + { + _vars => [ qw(step pings) ], + _mandatory => [ qw(step pings) ], + _doc => <<DOC, +Describes the properties of the round robin database for storing the +SmokePing data. Note that it is not possible to edit existing RRDs +by changing the entries in the cfg file. +DOC + + step => + { %$INTEGER_SUB, + _doc => <<DOC, +Duration of the base operation interval of SmokePing in seconds. +SmokePing will venture out every B<step> seconds to ping your target hosts. +If 'concurrent_probes' is set to 'yes' (see above), this variable can be +overridden by each probe. Note that the step in the RRD files is fixed when +they are originally generated, and if you change the step parameter afterwards, +you'll have to delete the old RRD files or somehow convert them. +DOC + }, + pings => + { + %$INTEGER_SUB, + _doc => <<DOC, +How many pings should be sent to each target. Suggested: 20 pings. +This can be overridden by each probe. Some probes (those derived from +basefork.pm, ie. most except the FPing variants) will even let this +be overridden target-specifically in the PROBE_CONF section (see the +basefork documentation for details). Note that the number of pings in +the RRD files is fixed when they are originally generated, and if you +change this parameter afterwards, you'll have to delete the old RRD +files or somehow convert them. +DOC + }, + + _table => + { + _doc => <<DOC, +This section also contains a table describing the setup of the +SmokePing database. Below are reasonable defaults. Only change them if +you know rrdtool and its workings. Each row in the table describes one RRA. + + # cons xff steps rows + AVERAGE 0.5 1 1008 + AVERAGE 0.5 12 4320 + MIN 0.5 12 4320 + MAX 0.5 12 4320 + AVERAGE 0.5 144 720 + MAX 0.5 144 720 + MIN 0.5 144 720 + +DOC + _columns => 4, + 0 => + { + _doc => <<DOC, +Consolidation method. +DOC + _re => '(AVERAGE|MIN|MAX)', + _re_error => "Choose a valid consolidation function", + }, + 1 => + { + _doc => <<DOC, +What part of the consolidated intervals must be known to warrant a known entry. +DOC + _sub => sub { + return "Xff must be between 0 and 1" + unless $_[ 0 ] > 0 and $_[ 0 ] <= 1; + return undef; + } + }, + 2 => {%$INTEGER_SUB, + _doc => <<DOC, +How many B<steps> to consolidate into for each RRA entry. +DOC + }, + + 3 => {%$INTEGER_SUB, + _doc => <<DOC, +How many B<rows> this RRA should have. +DOC + } + } + }, + Presentation => + { + _doc => <<DOC, +Defines how the SmokePing data should be presented. +DOC + _sections => [ qw(overview detail) ], + _mandatory => [ qw(overview template detail) ], + _vars => [ qw (template charset) ], + template => + { + _doc => <<DOC, +The webpage template must contain keywords of the form +B<E<lt>##>I<keyword>B<##E<gt>>. There is a sample +template included with SmokePing; use it as the basis for your +experiments. Default template contains a pointer to the SmokePing +counter and homepage. I would be glad if you would not remove this as +it gives me an indication as to how widely used the tool is. +DOC + + _sub => sub { + return "template '$_[0]' not readable" unless -r $_[ 0 ]; + return undef; + } + }, + charset => { + _doc => <<DOC, +By default, SmokePing assumes the 'iso-8859-15' character set. If you use +something else, this is the place to speak up. +DOC + }, + + overview => + { _vars => [ qw(width height range max_rtt median_color strftime) ], + _mandatory => [ qw(width height) ], + _doc => <<DOC, +The Overview section defines how the Overview graphs should look. +DOC + max_rtt => { _doc => <<DOC }, +Any roundtrip time larger than this value will cropped in the overview graph +DOC + median_color => { _doc => <<DOC, +By default the median line is drawn in red. Override it here with a hex color +in the format I<rrggbb>. +DOC + _re => '[0-9a-f]{6}', + _re_error => 'use rrggbb for color', + }, + strftime => { _doc => <<DOC, +Use posix strftime to format the timestamp in the left hand +lower corner of the overview graph +DOC + _sub => sub { + eval ( "POSIX::strftime( '$_[0]', localtime(time))" ); + return $@ if $@; + return undef; + }, + }, + + + width => + { + _sub => sub { + return "width must be be an integer >= 10" + unless $_[ 0 ] >= 10 + and int( $_[ 0 ] ) == $_[ 0 ]; + return undef; + }, + _doc => <<DOC, +Width of the Overview Graphs. +DOC + }, + height => + { + _doc => <<DOC, +Height of the Overview Graphs. +DOC + _sub => sub { + return "height must be an integer >= 10" + unless $_[ 0 ] >= 10 + and int( $_[ 0 ] ) == $_[ 0 ]; + return undef; + }, + }, + range => { _re => '\d+[smhdwy]', + _re_error => + "graph range must be a number followed by [smhdwy]", + _doc => <<DOC, +How much time should be depicted in the Overview graph. Time must be specified +as a number followed by a letter which specifies the unit of time. Known units are: +B<s>econds, B<m>inutes, B<h>ours, B<d>days, B<w>eeks, B<y>ears. +DOC + }, + }, + detail => + { + _vars => [ qw(width height logarithmic unison_tolerance max_rtt strftime nodata_color) ], + _sections => [ qw(loss_colors uptime_colors) ], + _mandatory => [ qw(width height) ], + _table => { _columns => 2, + _doc => <<DOC, +The detailed display can contain several graphs of different resolution. In this +table you can specify the resolution of each graph. + +Example: + + "Last 3 Hours" 3h + "Last 30 Hours" 30h + "Last 10 Days" 10d + "Last 400 Days" 400d + +DOC + 1 => + { + _doc => <<DOC, +How much time should be depicted. The format is the same as for the B<age> parameter of the Overview section. +DOC + _re => '\d+[smhdwy]', + _re_error => + "graph age must be a number followed by [smhdwy]", + }, + 0 => + { + _doc => <<DOC, +Description of the particular resolution. +DOC + } + }, + strftime => { _doc => <<DOC, +Use posix strftime to format the timestamp in the left hand +lower corner of the detail graph +DOC + _sub => sub { + eval ( " + POSIX::strftime('$_[0]', localtime(time)) " ); + return $@ if $@; + return undef; + }, + }, + nodata_color => { + _re => '[0-9a-f]{6}', + _re_error => "color must be defined with in rrggbb syntax", + _doc => "Paint the graph background in a special color when there is no data for this period because smokeping has not been running (#rrggbb)", + }, + logarithmic => { _doc => 'should the graphs be shown in a logarithmic scale (yes/no)', + _re => '(yes|no)', + _re_error =>"this must either be 'yes' or 'no'", + }, + unison_tolerance => { _doc => "if a graph is more than this factor of the median 'max' it drops out of the unison scaling algorithm. A factor of two would mean that any graph with a max either less than half or more than twice the median 'max' will be dropped from unison scaling", + _sub => sub { return "tolerance must be larger than 1" if $_[0] <= 1; return undef}, + }, + max_rtt => { _doc => <<DOC }, +Any roundtrip time larger than this value will cropped in the detail graph +DOC + width => { _doc => 'How many pixels wide should detail graphs be', + _sub => sub { + return "width must be be an integer >= 10" + unless $_[ 0 ] >= 10 + and int( $_[ 0 ] ) == $_[ 0 ]; + return undef; + }, + }, + height => { _doc => 'How many pixels high should detail graphs be', + _sub => sub { + return "height must be an integer >= 10" + unless $_[ 0 ] >= 10 + and int( $_[ 0 ] ) == $_[ 0 ]; + return undef; + }, + }, + + loss_colors => { + _table => { _columns => 3, + _doc => <<DOC, +In the Detail view, the color of the median line depends +the amount of lost packets. SmokePing comes with a reasonable default setting, +but you may choose to disagree. The table below +lets you specify your own coloring. + +Example: + + Loss Color Legend + 1 00ff00 "<1" + 3 0000ff "<3" + 100 ff0000 ">=3" + +DOC + 0 => + { + _doc => <<DOC, +Activate when the lossrate (in percent) is larger of equal to this number +DOC + _re => '\d+.?\d*', + _re_error => + "I was expecting a number", + }, + 1 => + { + _doc => <<DOC, +Color for this range. +DOC + _re => '[0-9a-f]+', + _re_error => + "I was expecting a color of the form rrggbb", + }, + + 2 => + { + _doc => <<DOC, +Description for this range. +DOC + } + + }, # table + }, #loss_colors + uptime_colors => { + _table => { _columns => 3, + _doc => <<DOC, +When monitoring a host with DYNAMIC addressing, SmokePing will keep +track of how long the machine is able to keep the same IP +address. This time is plotted as a color in the graphs +background. SmokePing comes with a reasonable default setting, but you +may choose to disagree. The table below lets you specify your own +coloring + +Example: + + # Uptime Color Legend + 3600 00ff00 "<1h" + 86400 0000ff "<1d" + 604800 ff0000 "<1w" + 1000000000000 ffff00 ">1w" + +Uptime is in days! + +DOC + 0 => + { + _doc => <<DOC, +Activate when uptime in days is larger of equal to this number +DOC + _re => '\d+.?\d*', + _re_error => + "I was expecting a number", + }, + 1 => + { + _doc => <<DOC, +Color for this uptime range range. +DOC + _re => '[0-9a-f]{6}', + _re_error => + "I was expecting a color of the form rrggbb", + }, + + 2 => + { + _doc => <<DOC, +Description for this range. +DOC + } + + },#table + }, #uptime_colors + + }, #detail + }, #present + Probes => { _sections => [ "/$KEY_RE/" ], + _doc => <<DOC, +The Probes Section configures Probe modules. Probe modules integrate an external ping command into SmokePing. Check the documentation of the FPing module for configuration details. +DOC + "/$KEY_RE/" => $PROBESTOP, + }, + Alerts => { + _doc => <<DOC, +The Alert section lets you setup loss and RTT pattern detectors. After each +round of polling, SmokePing will examine its data and determine which +detectors match. Detectors are enabled per target and get inherited by +the targets children. + +Detectors are not just simple thresholds which go off at first sight +of a problem. They are configurable to detect special loss or RTT +patterns. They let you look at a number of past readings to make a +more educated decision on what kind of alert should be sent, or if an +alert should be sent at all. + +The patterns are numbers prefixed with an operator indicating the type +of comparison required for a match. + +The following RTT pattern detects if a target's RTT goes from constantly +below 10ms to constantly 100ms and more: + + old ------------------------------> new + <10,<10,<10,<10,<10,>10,>100,>100,>100 + +Loss patterns work in a similar way, except that the loss is defined as the +percentage the total number of received packets is of the total number of packets sent. + + old ------------------------------> new + ==0%,==0%,==0%,==0%,>20%,>20%,>=20% + +Apart from normal numbers, patterns can also contain the values B<*> +which is true for all values regardless of the operator. And B<U> +which is true for B<unknown> data together with the B<==> and B<=!> operators. + +Detectors normally act on state changes. This has the disadvantage, that +they will fail to find conditions which were already present when launching +smokeping. For this it is possible to write detectors that begin with the +special value B<==S> it is inserted whenever smokeping is started up. + +You can write + + ==S,>20%,>20% + +to detect lines that have been losing more than 20% of the packets for two +periods after startup. + +Sometimes it may be that conditions occur at irregular intervals. But still +you only want to throw an alert if they occur several times within a certain +amount of times. The operator B<*X*> will ignore up to I<X> values and still +let the pattern match: + + >10%,*10*,>10% + +will fire if more than 10% of the packets have been losst twice over the +last 10 samples. + +A complete example + + *** Alerts *** + to = admin\@company.xy,peter\@home.xy + from = smokealert\@company.xy + + +lossdetect + type = loss + # in percent + pattern = ==0%,==0%,==0%,==0%,>20%,>20%,>20% + comment = suddenly there is packet loss + + +miniloss + type = loss + # in percent + pattern = >0%,*12*,>0%,*12*,>0% + comment = detected loss 3 times over the last two hours + + +rttdetect + type = rtt + # in milliseconds + pattern = <10,<10,<10,<10,<10,<100,>100,>100,>100 + comment = routing messed up again ? + + +rttbadstart + type = rtt + # in milliseconds + pattern = ==S,==U + comment = offline at startup + +DOC + + _sections => [ '/[^\s,]+/' ], + _vars => [ qw(to from) ], + _mandatory => [ qw(to from)], + to => { doc => <<DOC, +Either an email address to send alerts to, or the name of a program to +execute when an alert matches. To call a program, the first character of the +B<to> value must be a pipe symbol "|". The program will the be called +whenever an alert matches, using the following 5 arguments: +B<name-of-alert>, B<target>, B<loss-pattern>, B<rtt-pattern>, B<hostname>. +You can also provide a comma separated list of addresses and programs. +DOC + _re => '(\|.+|.+@\S+|snpp:)', + _re_error => 'put an email address or the name of a program here', + }, + from => { doc => 'who should alerts appear to be coming from ?', + _re => '.+@\S+', + _re_error => 'put an email address here', + }, + '/[^\s,]+/' => { + _vars => [ qw(type pattern comment to) ], + _mandatory => [ qw(type pattern comment) ], + to => { doc => 'Similar to the "to" parameter on the top-level except that it will only be used IN ADDITION to the value of the toplevel parameter. Same rules apply.', + _re => '(\|.+|.+@\S+|snpp:)', + _re_error => 'put an email address or the name of a program here', + }, + + type => { + _doc => 'Currently the pattern types B<rtt> and B<loss> and B<matcher> are known', + _re => '(rtt|loss|matcher)', + _re_error => 'Use loss or rtt' + }, + pattern => { + _doc => "a comma separated list of comparison operators and numbers. rtt patterns are in milliseconds, loss patterns are in percents", + _re => '(?:([^,]+)(,[^,]+)*|\S+\(.+\s)', + _re_error => 'Could not parse pattern or matcher', + }, + }, + }, + Targets => {_doc => <<DOC, +The Target Section defines the actual work of SmokePing. It contains a hierarchical list +of hosts which mark the endpoints of the network connections the system should monitor. +Each section can contain one host as well as other sections. +DOC + _vars => [ qw(probe menu title remark alerts) ], + _mandatory => [ qw(probe menu title) ], + _order => 1, + _sections => [ ( "PROBE_CONF", "/$KEY_RE/" ) ], + probe => { _doc => <<DOC }, +The name of the probe module to be used for this host. The value of +this variable gets propagated +DOC + PROBE_CONF => $PROBEVARS, + menu => { _doc => <<DOC }, +Menu entry for this section. If not set this will be set to the hostname. +DOC + alerts => { _doc => <<DOC }, +A comma separated list of alerts to check for this target. The alerts have +to be setup in the Alerts section. Alerts are inherited by child nodes. Use +an empty alerts definition to remove inherited alerts from the current target +and its children. + +DOC + title => { _doc => <<DOC }, +Title of the page when it is displayed. This will be set to the hostname if +left empty. +DOC + + remark => { _doc => <<DOC }, +An optional remark on the current section. It gets displayed on the webpage. +DOC + + "/$KEY_RE/" => $TARGET + } + + } + ); + return $parser; +} + +sub get_config ($$){ + my $parser = shift; + my $cfgfile = shift; + + return $parser->parse( $cfgfile ) || die "ERROR: $parser->{err}\n"; +} + +sub kill_smoke ($) { + my $pidfile = shift; + if (defined $pidfile){ + if ( -f $pidfile && open PIDFILE, "<$pidfile" ) { + <PIDFILE> =~ /(\d+)/; + my $pid = $1; + kill 2, $pid if kill 0, $pid; + sleep 3; # let it die + die "ERROR: Can not stop running instance of SmokePing ($pid)\n" + if kill 0, $pid; + close PIDFILE; + } else { + die "ERROR: Can not read pid from $pidfile: $!\n"; + }; + } +} + +sub daemonize_me ($) { + my $pidfile = shift; + if (defined $pidfile){ + if (-f $pidfile ) { + open PIDFILE, "<$pidfile"; + <PIDFILE> =~ /(\d+)/; + close PIDFILE; + my $pid = $1; + die "ERROR: I Quit! Another copy of $0 ($pid) seems to be running.\n". + " Check $pidfile\n" + if kill 0, $pid; + } + } + print "Warning: no logging method specified. Messages will be lost.\n" + unless $logging; + print "Daemonizing $0 ...\n"; + defined (my $pid = fork) or die "Can't fork: $!"; + if ($pid) { + exit; + } else { + if(open(PIDFILE,">$pidfile")){ + print PIDFILE "$$\n"; + close PIDFILE; + } else { + warn "creating $pidfile: $!\n"; + }; + require 'POSIX.pm'; + &POSIX::setsid or die "Can't start a new session: $!"; + open STDOUT,'>/dev/null' or die "ERROR: Redirecting STDOUT to /dev/null: $!"; + open STDIN, '</dev/null' or die "ERROR: Redirecting STDIN from /dev/null: $!"; + open STDERR, '>/dev/null' or die "ERROR: Redirecting STDERR to /dev/null: $!"; + # send warnings and die messages to log + $SIG{__WARN__} = sub { do_log ((shift)."\n") }; + $SIG{__DIE__} = sub { do_log ((shift)."\n"); exit 1 }; + } +} + +# pseudo log system object +{ + my $use_syslog; + my $use_cgilog; + my $use_debuglog; + my $use_filelog; + + my $syslog_facility; + my $syslog_priority = $DEFAULTPRIORITY; + + sub initialize_debuglog (){ + $use_debuglog = 1; + } + + sub initialize_cgilog (){ + $use_cgilog = 1; + $logging=1; + } + + sub initialize_filelog ($){ + $use_filelog = shift; + $logging=1; + } + + sub initialize_syslog ($$) { + my $fac = shift; + my $pri = shift; + $use_syslog = 1; + $logging=1; + die "missing facility?" unless defined $fac; + $syslog_facility = $fac if defined $fac; + $syslog_priority = $pri if defined $pri; + print "Note: logging to syslog as $syslog_facility/$syslog_priority.\n"; + openlog(basename($0), 'pid', $syslog_facility); + } + + sub do_syslog ($){ + syslog("$syslog_facility|$syslog_priority", shift); + } + + sub do_cgilog ($){ + my $str = shift; + print "<p>" , $str, "</p>\n"; + print STDERR $str,"\n"; # for the webserver log + } + + sub do_debuglog ($){ + do_log(shift) if $use_debuglog; + } + + sub do_filelog ($){ + open X,">>$use_filelog" or return; + print X scalar localtime(time)," - ",shift,"\n"; + close X; + } + + sub do_log (@){ + my $string = join(" ", @_); + chomp $string; + do_syslog($string) if $use_syslog; + do_cgilog($string) if $use_cgilog; + do_filelog($string) if $use_filelog; + print STDERR $string,"\n" unless $logging; + } + +} + +########################################################################### +# The Main Program +########################################################################### + +my $RCS_VERSION = '$Id: Smokeping.pm,v 1.5 2004/10/21 21:10:51 oetiker Exp $'; + +sub load_cfg ($) { + my $cfgfile = shift; + my $cfmod = (stat $cfgfile)[9] || die "ERROR: calling stat on $cfgfile: $!\n"; + # when running under speedy this will prevent reloading on every run + # if cfgfile has been modified we will still run. + if (not defined $cfg or $cfg->{__last} < $cfmod ){ + $cfg = undef; + my $parser = get_parser; + $cfg = get_config $parser, $cfgfile; + $cfg->{__parser} = $parser; + $cfg->{__last} = $cfmod; + $cfg->{__cfgfile} = $cfgfile; + $probes = undef; + $probes = load_probes $cfg; + $cfg->{__probes} = $probes; + init_alerts $cfg if $cfg->{Alerts}; + init_target_tree $cfg, $probes, $cfg->{Targets}{probe}, $cfg->{Targets}, $cfg->{General}{datadir}, $cfg->{Targets}{PROBE_CONF},$cfg->{Targets}{alerts},undef; + } +} + + +sub makepod ($){ + my $parser = shift; + my $e='='; + print <<POD; + +${e}head1 NAME + +smokeping_config - Reference for the SmokePing Config File + +${e}head1 OVERVIEW + +SmokePing takes its configuration from a single central configuration file. +Its location must be hardcoded in the smokeping script and smokeping.cgi. + +The contents of this manual is generated directly from the configuration +file parser. + +The Parser for the Configuration file is written using David Schweikers +ParseConfig module. Read all about it in L<ISG::ParseConfig>. + +The Configuration file has a tree-like structure with section headings at +various levels. It also contains variable assignments and tables. + +${e}head1 REFERENCE + +The text below describes the syntax of the SmokePing configuration file. + +POD + + print $parser->makepod; + print <<POD; + +${e}head1 COPYRIGHT + +Copyright (c) 2001-2003 by Tobias Oetiker. All right reserved. + +${e}head1 LICENSE + +This program is free software; you can redistribute it +and/or modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later +version. + +This program is distributed in the hope that it will be +useful, but WITHOUT ANY WARRANTY; without even the implied +warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +PURPOSE. See the GNU General Public License for more +details. + +You should have received a copy of the GNU General Public +License along with this program; if not, write to the Free +Software Foundation, Inc., 675 Mass Ave, Cambridge, MA +02139, USA. + +${e}head1 AUTHOR + +Tobias Oetiker E<lt>tobi\@oetiker.chE<gt> + +${e}cut +POD + exit 0; + + +} +sub cgi ($) { + $cgimode = 'yes'; + # make sure error are shown in appropriate manner even when running from speedy + # and thus not getting BEGIN re-executed. + if ($ENV{SERVER_SOFTWARE}) { + $SIG{__WARN__} = sub { print "Content-Type: text/plain\n\n".(shift)."\n"; }; + $SIG{__DIE__} = sub { print "Content-Type: text/plain\n\n".(shift)."\n"; exit 1 } + }; + umask 022; + load_cfg shift; + my $q=new CGI; + print $q->header(-type=>'text/html', + -expires=>'+'.($cfg->{Database}{step}).'s', + -charset=> ( $cfg->{Presentation}{charset} || 'iso-8859-15') + ); + if ($ENV{SERVER_SOFTWARE}) { + $SIG{__WARN__} = sub { print "<pre>".(shift)."</pre>"; }; + $SIG{__DIE__} = sub { print "<pre>".(shift)."</pre>"; exit 1 } + }; + initialize_cgilog(); + if ($q->param(-name=>'secret') && $q->param(-name=>'target') ) { + update_dynaddr $cfg,$q; + } else { + display_webpage $cfg,$q; + } +} + + +sub gen_page ($$$); +sub gen_page ($$$) { + my ($cfg, $tree, $open) = @_; + my ($q, $name, $page); + + $q = bless \$q, 'dummyCGI'; + + $name = @$open ? join('.', @$open) . ".html" : "index.html"; + + die "Can not open $cfg-{General}{pagedir}/$name for writing: $!" unless + open PAGEFILE, ">$cfg->{General}{pagedir}/$name"; + + my $step = $probes->{$tree->{probe}}->step(); + + $page = fill_template + ($cfg->{Presentation}{template}, + { + menu => target_menu($cfg->{Targets}, + [@$open], #copy this because it gets changed + "", ".html"), + title => $tree->{title}, + remark => ($tree->{remark} || ''), + overview => get_overview( $cfg,$q,$tree,$open ), + body => get_detail( $cfg,$q,$tree,$open ), + target_ip => ($tree->{host} || ''), + owner => $cfg->{General}{owner}, + contact => $cfg->{General}{contact}, + author => '<A HREF="http://tobi.oetiker.ch/">Tobi Oetiker</A>', + smokeping => '<A HREF="http://people.ee.ethz.ch/~oetiker/webtools/smokeping/counter.cgi/'.$VERSION.'">SmokePing-'.$VERSION.'</A>', + step => $step, + rrdlogo => '<A HREF="http://people.ee.ethz.ch/~oetiker/webtools/rrdtool/"><img border="0" src="'.$cfg->{General}{imgurl}.'/rrdtool.png"></a>', + smokelogo => '<A HREF="http://people.ee.ethz.ch/~oetiker/webtools/smokeping/counter.cgi/'.$VERSION.'"><img border="0" src="'.$cfg->{General}{imgurl}.'/smokeping.png"></a>', + }); + + print PAGEFILE $page; + close PAGEFILE; + + foreach my $key (keys %$tree) { + my $value = $tree->{$key}; + next unless ref($value) eq 'HASH'; + gen_page($cfg, $value, [ @$open, $key ]); + } +} + +sub makestaticpages ($$) { + my $cfg = shift; + my $dir = shift; + + # If directory is given, override current values (pagedir and and + # imgurl) so that all generated data is in $dir. If $dir is undef, + # use values from config file. + if ($dir) { + mkdir $dir, 0755 unless -d $dir; + $cfg->{General}{pagedir} = $dir; + $cfg->{General}{imgurl} = '.'; + } + + die "ERROR: No pagedir defined for static pages\n" + unless $cfg->{General}{pagedir}; + # Logos. + gen_imgs($cfg); + + # Iterate over all targets. + my $tree = $cfg->{Targets}; + gen_page($cfg, $tree, []); +} + +sub pages ($) { + my ($config) = @_; + umask 022; + load_cfg($config); + makestaticpages($cfg, undef); +} + +sub main ($) { + $cgimode = 0; + umask 022; + my $cfgfile = shift; + $opt{filter}=[]; + GetOptions(\%opt, 'version', 'email', ,'man','help','logfile=s','static-pages:s', 'debug-daemon', + 'nosleep', 'makepod','debug','restart', 'filter=s', 'nodaemon|nodemon') or pod2usage(2); + if($opt{version}) { print "$RCS_VERSION\n"; exit(0) }; + if($opt{man}) { pod2usage(-verbose => 2); exit 0 }; + if($opt{help}) { pod2usage(-verbose => 1); exit 0 }; + if($opt{makepod}) { makepod(get_parser) ; exit 0}; + initialize_debuglog if $opt{debug} or $opt{'debug-daemon'}; + load_cfg $cfgfile; + if(defined $opt{'static-pages'}) { makestaticpages $cfg, $opt{'static-pages'}; exit 0 }; + if($opt{email}) { enable_dynamic $cfg, $cfg->{Targets},"",""; exit 0 }; + if($opt{restart}) { kill_smoke $cfg->{General}{piddir}."/smokeping.pid";}; + if($opt{logfile}) { initialize_filelog($opt{logfile}) }; + if (not keys %$probes) { + do_log("No probes defined, exiting."); + exit 1; + } + unless ($opt{debug} or $opt{nodaemon}) { + if (defined $cfg->{General}{syslogfacility}) { + initialize_syslog($cfg->{General}{syslogfacility}, + $cfg->{General}{syslogpriority}); + } + daemonize_me $cfg->{General}{piddir}."/smokeping.pid"; + } + do_log "Launched successfully"; + + my $myprobe; + my $forkprobes = $cfg->{General}{concurrentprobes} || 'yes'; + if ($forkprobes eq "yes" and keys %$probes > 1 and not $opt{debug}) { + my %probepids; + my $pid; + do_log("Entering multiprocess mode."); + for my $p (keys %$probes) { + if ($probes->{$p}->target_count == 0) { + do_log("No targets defined for probe $p, skipping."); + next; + } + my $sleep_count = 0; + do { + $pid = fork; + unless (defined $pid) { + do_log("Fatal: cannot fork: $!"); + die "bailing out" + if $sleep_count++ > 6; + sleep 10; + } + } until defined $pid; + $myprobe = $p; + goto KID unless $pid; # child skips rest of loop + do_log("Child process $pid started for probe $myprobe."); + $probepids{$pid} = $myprobe; + } + # parent + do_log("All probe processes started succesfully."); + my $exiting = 0; + for my $sig (qw(INT TERM)) { + $SIG{$sig} = sub { + do_log("Got $sig signal, terminating child processes."); + $exiting = 1; + kill $sig, $_ for keys %probepids; + my $now = time; + while(keys %probepids) { # SIGCHLD handler below removes the keys + if (time - $now > 2) { + do_log("Can't terminate all child processes, giving up."); + exit 1; + } + sleep 1; + } + do_log("All child processes succesfully terminated, exiting."); + exit 0; + } + }; + $SIG{CHLD} = sub { + while ((my $dead = waitpid(-1, WNOHANG)) > 0) { + my $p = $probepids{$dead}; + $p = 'unknown' unless defined $p; + do_log("Child process $dead (probe $p) exited unexpectedly with status $?.") + unless $exiting; + delete $probepids{$dead}; + } + }; + sleep while 1; # just wait for the signals + do_log("Exiting abnormally - this should not happen."); + exit 1; # not reached + } else { + if ($forkprobes ne "yes") { + do_log("Not entering multiprocess mode because the 'concurrentprobes' variable is not set."); + for my $p (keys %$probes) { + for my $what (qw(offset step)) { + do_log("Warning: probe-specific parameter '$what' ignored for probe $p in single-process mode." ) + if defined $cfg->{Probes}{$p}{$what}; + } + } + } elsif ($opt{debug}) { + do_debuglog("Not entering multiprocess mode with '--debug'. Use '--debug-daemon' for that.") + } elsif (keys %$probes == 1) { + do_log("Not entering multiprocess mode for just a single probe."); + $myprobe = (keys %$probes)[0]; # this way we won't ignore a probe-specific step parameter + } + for my $sig (qw(INT TERM)) { + $SIG{$sig} = sub { + do_log("Got $sig signal, terminating."); + exit 1; + } + } + } +KID: + my $offset; + my $step; + if (defined $myprobe) { + $offset = $probes->{$myprobe}->offset || 'random'; + $step = $probes->{$myprobe}->step; + $0 .= " [$myprobe]" unless defined $cfg->{General}{changeprocessnames} + and $cfg->{General}{changeprocessnames} eq "no"; + } else { + $offset = $cfg->{General}{offset} || 'random'; + $step = $cfg->{Database}{step}; + } + if ($offset eq 'random'){ + $offset = int(rand($step)); + } else { + $offset =~ s/%$//; + $offset = $offset / 100 * $step; + } + for (keys %$probes) { + next if defined $myprobe and $_ ne $myprobe; + # fill this in for report_probes() below + $probes->{$_}->offset_in_seconds($offset); # this is just for humans + if ($opt{debug} or $opt{'debug-daemon'}) { + $probes->{$_}->debug(1) if $probes->{$_}->can('debug'); + } + } + + report_probes($probes, $myprobe); + + while (1) { + unless ($opt{nosleep} or $opt{debug}) { + my $sleeptime = $step - (time-$offset) % $step; + if (defined $myprobe) { + $probes->{$myprobe}->do_debug("Sleeping $sleeptime seconds."); + } else { + do_debuglog("Sleeping $sleeptime seconds."); + } + sleep $sleeptime; + } + my $now = time; + run_probes $probes, $myprobe; # $myprobe is undef if running without 'concurrentprobes' + update_rrds $cfg, $probes, $cfg->{Targets}{probe}, $cfg->{Targets}, $cfg->{General}{datadir}, $myprobe; + exit 0 if $opt{debug}; + my $runtime = time - $now; + if ($runtime > $step) { + my $warn = "WARNING: smokeping took $runtime seconds to complete 1 round of polling. ". + "It should complete polling in $step seconds. ". + "You may have unresponsive devices in your setup.\n"; + if (defined $myprobe) { + $probes->{$myprobe}->do_log($warn); + } else { + do_log($warn); + } + } + } +} + +sub gen_imgs ($){ + + my $cfg = shift; + if (not -r $cfg->{General}{imgcache}."/rrdtool.png"){ +open W, ">".$cfg->{General}{imgcache}."/rrdtool.png" + or do { warn "WARNING: creating $cfg->{General}{imgcache}/rrdtool.png: $!\n"; return 0 }; +print W unpack ('u', <<'UUENC'); +MB5!.1PT*&@H -24A$4@ '@ B! , !F7P!P +5!,5$44&5T0 +M.(L@2)8N6* X9JQ)=+)QC[Q7AL"9J;63KL^SR=[]^\S____K^?S6XN6'_*P9 +M &D$E$051XVIV5_T\;YQW'37Z(M"Z+>!XW3B&VQ3U'$ 6&N#L;D9JAF+MK +M:(FB4M\%.C,4DX8HX"%-PK+29M$@0:,CL@H$4F<TBE&:U!VM-&,(433$D>#% +M["Y:VB3J-AOA X97_Z&?1XS;=I^V _[G.\>VWI>S_MY/L_[^9QIYW_%\FZS +M3>_MG>5M>&YO+L_]81/:OZ5G3&O!YB!$(-B<"U7M46595A1%EJ5<B! .0>!Y +M@65YGO#DGX%1E6D]^-]!!Z/#T"L04',APX@>59(E17(ZG;(31A.$HZ:70;7Y +M/]#F8" 0""J2),,T)%55)$41!5GQP%R D"2GX'#\"[X_1Z&/SSX+Y-!=V<'[ +M]Z=!,2ZK7IC_X)P(3U$0I[ULCA-<K"#0:6<_O@;$!X'X^3BTZC%54=5 T'OV +M0X]3CDE2@U-JF&Z;$GBALI?O\YIY ;,\^2%" +\,QD^LWPZ^_"80OSAW)JB$ +MOFBXF 7-<L73EG7,;@A_=\@N#S]].-3GG:M9;32O"3OO5]:U6'9X4 [<VU3N +M*<^Z>IY^<#>@MMW=K)OY+>3'I<HS7:=GNB8&':*WN'ZVO'_6WE\2\Q[J\W9, +MEV>)JV47OG'K7L]T8T_\G7BSVBBY3EQV09Y<2MUJS>JWCIBW6.PJKM\("5WV +M/B[F#:$-/G0(D_*CYB* GP;B&PJ%6]8"S5ZGJZT?5.5RM>YRS8M8_51CL=AH +MYF8V=S;LO=R4:Q/-[6P<POR!^X0JQ^7X*Y'";T_)JDMRU8$RP)Z&U<+56'&L +MD17+?<53(83LO4S,]<;*1EX>*.?O[P5E]=[FK=^%[C;VS!V;O:R>F)FKO.Q2 +M9,FE.&8'Q=G!2UY6J)X=['4-3)7.-L6\*.X:^'VY&9=W_:K*M-8<OB8WW!EM +M4-JD[JN*I_M2]8<-X*$:C]C2[QCX-5LC"%S;.DM"[<Q 4U\IKC8/^$KS2&D6 +M%YG6Z+:"E7M4<!*XCX8#;L$IB.#HW$?@B,!BL#5#&)9A$$($YR,",!AXU[U +MRY*ZBXO4PD").3O1,\&RA%X, T>"P"B8W9-3IGW!NR+8SP&BX#]6$"D&O5E" +M6%X ,4+/$Q5%A&IC& 3@=\Z';T3''/*Q.^'KT;%ZASAZKB-\E@!;.M9!HYUE +M#GZ]Y*-ZZ,A6%&%LJ3[9A FL^;L3=_3LYWK"(2]L):_KC_GZQ 6C4W\.=)F^ +M/:$OZ1E2>&&Q1A_"#.K<.NU?0HRU1>]E"%]D>O%N^/B(,)[N<3S\2".UZ8S[ +M^=4DMNG# ENP:(E6W*S(,'_=QR *V5>>H]?U#+)U'/<1NN;5M\*=(])/4JON +MQ8D%\4WC ??J3)0M,1:)8(\4C)V,6)[80[4(V5(^YL8=#>5O+R';N=:CD+8< +M[!^1?IR:<#_H7G"4 )R]EC0SQK*9KR26L=8(LU)Q8&>/VVYH2/OIGXN9SU/N +M?257?(3DX*OZB&A-G79K6YI08FA<]G@2<]LIJ%?DC2$]@KAH1<*>+C 2EDPJ +M,OG,GQZR'M:;"(:$?5LV,CDBUCYF.>UGFE"HO\_=KDR: 895\9:;_IL$/2U; +MS#=9C&1A^_BG^:;:](K-G6K*;=7JD? OA\GDL,!ISS74NHZY[-A?,+.=&B)5 +MG.6+3R*XZ(\CBU=TV5C>_Y%U5$]4I#7;NQ6GP"=4^:O*L:\39H%+>K1O#,1R +MKX:S%/9!2BS7W\X0I*TMFKF]QK+]?/>GQ4QM>M[VF;4IE[ 7;XY.MNMI LH_ +MU\93O83)'DE2^!3A&,N$/X.+'IY+%$0+C$>OG?5'.H=;TT]^A+<X\%F1Z4G9 +ML#[D3T581IO4K.D%S&0KDJC(2#'L'F*YJ4<(^L2:+(@6IA\>6$E%KD?\*9_- +MHS=AY*;PZ/B0S5ADN?F+\P>-QYBY?3*!D?$G\#"QW&J-$*;"LHS0:[!5#SKG +M$1I/<39Y'*:M%9DR9>&WA@X;*4P6VS6Z5)1M_Q)9C =P[,C!+ZM7&*;@>RM" +MUM0OD/_2 D)&$NWKL#8A6P:4[><N##%;Z0S6PAID8P&MCR:1'>8%RC^X[<\0 +MDC\)?2>3>YB]6A+MU3/86GKA/;05 =CZF?Z"J]4?631] >W7]:KOKSPZHG\' +MPIBQ9_5YS# 6_U+W8Q_&Z*2>W4H@LJ]37]9UJGR8,[N)F7?B]Q!/$%0-MW"F +MICTO]R:$UP,'#3+_)EJ%Z)>2K_KS,#&_3DL$!VOFZ7FGM2$7M%+ 8<?DWS]) +GK@CL_D-K0>[]"@'[?,KT_\<_ *X%"4UQ:&PM $E%3D2N0F"" +UUENC +close W; +} + + if (not -r $cfg->{General}{imgcache}."/smokeping.png"){ +open W, ">".$cfg->{General}{imgcache}."/smokeping.png" + or do { warn "WARNING: creating $cfg->{General}{imgcache}/smokeping.png: $!\n"; return 0}; +print W unpack ('u', <<'UUENC'); +MB5!.1PT*&@H````-24A$4@```'@````6"`,````\1*C*```#`%!,5$7___\2 +M*FINUAH.Q"X+DD(.<DYFUAX.8E:"GL`.5EH2JCH.3ETB@D9RCK4NJC8.1EXT +MK#)ZVAI&8I+^ID(2/F(^5HJ;ZPXZKC+&>#SRF$"6MM(2.F(R3H(^LBYNCK*Z +MWNY:/DJI\@INBK$2-F:P:CZJSN(R2H+DCCXZ5HJRUNF46CYFPB+"YO52<IXN +M1GY(.E(NECX2,F8J0GHJBD**JLBV^0:>OM>*4CX*AD8IIC;"=CY*SB(X-EDF +M/G@JGCH2+FIFAJXB.G9:=J+*[OHJ1GV^^@)ZFKL-=DYJ1D9:PB:.\@Y*9I87 +MCD(>-G(.:E).[A85H3M^WA:BQMPZMBYE@JH>>DI2/DXD,F+"_@*"XA9!MRT; +M+F9".E9.:I8:PBYVEKH+?DHDESZ.KLM>>J6:]@HB/G9*PBINZA(>.G-"7H_* +MZOH6,FX6+FH/7E8R-EY^SAYFWAH6DD*6XA)6RB8>JC9FRB(NIC9*MBH2AD;& +MZO:"HL+2\OX:>$H*GCX:-G(7@4<V4H:^XO*VVNHFRBJ&HL*:NM*>PMK.\OY2 +M;IPN-EZF^@;&_@(.2EX.6ED20F*RTN:2LLYB?J<:9E(.4EITX!8,FCX6ED)R +MDK:JRN%GSA\6AD8JO"XF0GIFXAH.;E%*OBHBGCH/9E-:RB*.Z!(^6HT::D[. +M[OS&YO:P]@82?TI^GKXN2G\NGCJB^@86+FY"LBX:,FZ2YA(>@D9&OBINTAZ* +MZA(*>DV6^@J^WN^ZVNXHK#9RRAX6<DZZ^@/.?C[ZGD)>QB9N\A*Q^@:B[@YZ +MEKK"XO(V3H5JAJZ*IL869E(VECZB\PH>AD9BS2(Z4H:VUNJ.JLHNKC90OBIA +M04D22EXNFCIHTAX6BD9VUAH:KC9^FKZ*Y!)2Q"9NW!IVDK9*KBY"6HZNSN.2 +MKLX*@DH0BD825EH28E821E]6<IY..DYBOB:6\@ZFQMXJ,EY&NBI&7I*BPMIN +MYA:^_@)*NBJ&IL6Z_@)JBJX2.F8:DD(.ED(JHCF5Z@Z:NM:6LLX.>DM.:II/ +M<@=C`````7123E,`0.;89@``!Q=)1$%4>-K%5G]46U<=[W/$D,60+81ZEN00 +M-P8+,V0-)M'59C?A!7`^@NN*ZSO#F)&(DI?'%'_4OE33@*3)\4%^'-I"-\9& +MBP1!C[$Z3%3<T9)2K1+6SE;7E15HUQP/MN^DP#EK5X_WO01*Z_[TG'US\NY[ +MWW?O_7X_]_OC\[8@'Y%L`1^1;,D[0)+_=TP`?(A*NZ[,&3;/2C"7)@[M6Q16 +M3N.V&/,>6:LUU>9X[CX>)SDG2?;/R>9MM:$^*%?E`,A[A')MZ"UY3E]V52@% +MW"C@M_?VR-E[#C&IB>J89;]=8D6LP9D1;K.*:,;,OJ_&3'6>NIE@A1L!UI$: +MFX8D*VP9R80*LT'!2JR;#(=^O^?-HJ*6^KY0^[:?O2=L_$NCE-U"V_>9;7^6 +M`FU/8\?S1[]WIF5(J,W'N"W*$(2:2G3[@&7:T-0&5=:,K,X"@'MVS9^.$922 +ML5_W(IK^@=N8U]=O8$09^S(G=;X[4=,*WJ6AX%M;ALYG:_?S&_3/#X7@><N' +MOEV[K4<KN'QNBGU?^^#^'I!#K%@A.F\7^A<\)<T^1^+4+*L:3T1*$$155XFF +MRIGR))7LEK@K5JCRC$H4I@Q.+((&8NI4*G)I4P![;]`_?N7@&'VLX%!MMH/? +M@6=_Q8.6Y;Q;JS?[A.<OT+4[W_GZQ3'\F^W:7(Q=LD#8I)#42-K<-@,ZX+0B +MWB"#,C;2.!,>71BOP8)VAE).*WPZ8J%?5!YCHM4C$:++(2HMK1KD`M/,A;CW +M!O[Z#PM>SNJ_>__J:@?_,$[C[TR*H>%?9F^V\_Y!/_SF))_/Z_CT?GC6$#%` +M5#HJL8)9K"3BC58&.CTGD8GI1*#2:77=1BM%OCA,@J9E8CD(YR4/#%",R4*6 +MR`BFIGK0R.8!^>)S9Y_8#4?!#?I"P=(_]?K?WL\ASD[A]-'_]$CKH>&AI_13 +MNQJE$+_PRENY&"/(X,Q"0"E;<UF!Q9[8%V"J6FT'1O<E^B><8731Q4("BD)U +M0H3IB-$8.K!F04A7!`V/1YU.22M`=GSVL8>VG]W-'C7^^E=?/D@_?.B9J=H" +MB/CG7X*6)WOK;V6??.$,OO6R&`!ISQ6!0"C/(0:^-29&I!U!L\I!$41B&IM7 +MHJ/4BFLM0=4-<H5G-J6I\:"#VA=0SY60;'10HJNR,CP^"YH_]=@;Q<6/[@!L +MC'$H4[^H/[R*LXA/W_?Y+'VNX-`M?,_2$7HGKPR1\_]>5%2TK;TL5\>D)N-9 +M(-2+6-"@7@C'ED\Q:%=7S!\L3:7FC6PC`-YH.M:=T:&!`.6WP;-W^4?19#I= +MZ5$AS5]XJ+BX>/M7$"T\ZJ]]Z]S3+<.]#3G$I]]?NK9*'[SOBZM%G_L;OK-> +M"L2?F,)Q6E\?XA`C;4:SS\2@Z5)16.GQI"FE.GG*T3D0-741<R>YC-78.SOG +M@PXTE8PI/2H2<1G0<)T3'C5L,\_]H;CXC<=?9).+OE@P+.B1BQMJ(>+#V1-+ +M?4.[]/@??U/[Y.0-^L1E,2+_R;\^_@U\;%+*(B853I/$J^A.);M7D@/.H)\8 +M)60U:VGE(S4'`N5-U=`U<Y6?6(A*%JD%AX$(]T^0$O^H7Q+76MF.MOOLH]L? +M?P(F@N`:_K$A.6R*XH95B+@#/_U3J;3Q`3V.P^1J&5N]Q@N5B8??_Q&]M5[. +MUG$\:$C/14U^JE+GC_DE%KLRT/6()KBL?EMB5U)^TZ63*F=$K=:-P!IBHC/E +MQ$#3($1LL%4;6ZUL!C3OV/'O9JZ<Z%\WPHP%XH:I'.(7I(AT>,\8GGVJG7<$ +M']NUU,BO?^88_C1?RR'&_%0J'%:K96\SZA5%W&:(W<;<EV34XB7)7`H-RW21 +M\IA:5M6FBE`&FV\^K?9GJ@RCZ<7I.I'-"#88`0B^3Y\;AB6*B,]O(`:@;/BU +ML>Q-H?"E"W3VV-'O7/P3?6NO&&8U7-'JE'6I4\E(4Y-LV61$)NP'9HRP@)2R +MZU:L,$RA!$$E'1DC61*)?8!97:<Z8W/V9_<%J!@%:WZ=;0"B[7N7_AW;E!#Q +M_BG\I?:]^`D>K!N8R:]MA2VS;^\1/6RH>/;!\X)\YT*,6-.\O4EB5#B=LVXD +M+G%"HK!BHJB"U*JBA3*#7V=RF4DPT>0H]0&OK?"#%9''\"QLU4QI1=XJ1Q+# +M?^6)`>O"E>/'!:$KQW_0Q[J!R'N__!Y+$L.7'WCUS"<[>"Q)<+T:(&XK#!?D +M.J^7!/`ZR.:,=[#5#8>VB1'72(69;2-QC6HB#DG*YW*=5%UGZ0GS>0&9XUUX +M)>576?J#=V5B<1EDP9`VYY0V)&5ME8F%`@%+FSD^!F3>97`78W-/9%Z9VYH= +M0&Z$/VB0),%FS@?_R_[Y->O:.TYN?(%L&`?K1I%-ON3-W3T7N?=Y?=VZ`P`@ +M=QRZ"U#^"P1\".0[*')SP89]!-SK#-CD]Z:-[IX'[CF(_P)F$_VEE.-5```` +*``!)14Y$KD)@@@`` +UUENC +close W; +} +} + + +=head1 NAME + +Smokeping.pm - SmokePing Perl Module + +=head1 OVERVIEW + +Almost all SmokePing functionality sits in this Module. +The programs B<smokeping> and B<smokeping.cgi> are merely +figure heads allowing to hardcode some pathnames. + +If you feel like documenting what is happening within this library you are +most welcome todo so. + +=head1 COPYRIGHT + +Copyright (c) 2001 by Tobias Oetiker. All right reserved. + +=head1 LICENSE + +This program is free software; you can redistribute it +and/or modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 2 of the License, or (at your option) any later +version. + +This program is distributed in the hope that it will be +useful, but WITHOUT ANY WARRANTY; without even the implied +warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR +PURPOSE. See the GNU General Public License for more +details. + +You should have received a copy of the GNU General Public +License along with this program; if not, write to the Free +Software Foundation, Inc., 675 Mass Ave, Cambridge, MA +02139, USA. + +=head1 AUTHOR + +Tobias Oetiker E<lt>tobi\@oetiker.chE<gt> + +=cut + +# Emacs Configuration +# +# Local Variables: +# mode: cperl +# eval: (cperl-set-style "PerlStyle") +# mode: flyspell +# mode: flyspell-prog +# End: +# +# vi: sw=4 diff --git a/lib/ciscoRttMonMIB.pm b/lib/ciscoRttMonMIB.pm new file mode 100644 index 0000000..8b0abb4 --- /dev/null +++ b/lib/ciscoRttMonMIB.pm @@ -0,0 +1,111 @@ +# +# +# a few variable definitions to use ciscoRttMonMIB +# +# Joerg Kummer, 10/9/03 +# + +package ciscoRttMonMIB; + +require 5.004; + +use vars qw($VERSION); +use Exporter; + +use BER; +use SNMP_Session; +use SNMP_util "0.89"; + +$VERSION = '0.2'; + +@ISA = qw(Exporter); + +sub version () { $VERSION; }; + +snmpmapOID("rttMonApplVersion", "1.3.6.1.4.1.9.9.42.1.1.1.0"); +snmpmapOID("rttMonApplSupportedRttTypesValid", "1.3.6.1.4.1.9.9.42.1.1.7.1.2"); + +# generic variables for all measurement types +# cisco(9).ciscoMgmt(9).ciscoRttMonMIB(42).ciscoRttMonObjects(1).rttMonCtrl(2).rttMonCtrlAdminTable(1).rttMonCtrlAdminEntry(1) +snmpmapOID("rttMonCtrlAdminIndex", "1.3.6.1.4.1.9.9.42.1.2.1.1.1"); +snmpmapOID("rttMonCtrlAdminOwner", "1.3.6.1.4.1.9.9.42.1.2.1.1.2"); +snmpmapOID("rttMonCtrlAdminTag", "1.3.6.1.4.1.9.9.42.1.2.1.1.3"); +snmpmapOID("rttMonCtrlAdminRttType", "1.3.6.1.4.1.9.9.42.1.2.1.1.4"); +snmpmapOID("rttMonCtrlAdminThreshold", "1.3.6.1.4.1.9.9.42.1.2.1.1.5"); +snmpmapOID("rttMonCtrlAdminFrequency", "1.3.6.1.4.1.9.9.42.1.2.1.1.6"); +snmpmapOID("rttMonCtrlAdminTimeout", "1.3.6.1.4.1.9.9.42.1.2.1.1.7"); +snmpmapOID("rttMonCtrlAdminVerifyData", "1.3.6.1.4.1.9.9.42.1.2.1.1.8"); +snmpmapOID("rttMonCtrlAdminStatus", "1.3.6.1.4.1.9.9.42.1.2.1.1.9"); +snmpmapOID("rttMonCtrlAdminNvgen", "1.3.6.1.4.1.9.9.42.1.2.1.1.10"); + + +#1. For echo, pathEcho and dlsw operations +# cisco(9).ciscoMgmt(9).ciscoRttMonMIB(42).ciscoRttMonObjects(1).rttMonCtrl(2).rttMonEchoAdminTable(2).rttMonEchoAdminEntry (1) +snmpmapOID("rttMonEchoAdminProtocol", "1.3.6.1.4.1.9.9.42.1.2.2.1.1"); +snmpmapOID("rttMonEchoAdminTargetAddress", "1.3.6.1.4.1.9.9.42.1.2.2.1.2"); +snmpmapOID("rttMonEchoAdminPktDataRequestSize", "1.3.6.1.4.1.9.9.42.1.2.2.1.3"); +snmpmapOID("rttMonEchoAdminPktDataResponseSize", "1.3.6.1.4.1.9.9.42.1.2.2.1.4"); +snmpmapOID("rttMonEchoAdminTargetPort", "1.3.6.1.4.1.9.9.42.1.2.2.1.5"); +snmpmapOID("rttMonEchoAdminSourceAddress", "1.3.6.1.4.1.9.9.42.1.2.2.1.6"); +snmpmapOID("rttMonEchoAdminSourcePort", "1.3.6.1.4.1.9.9.42.1.2.2.1.7"); +snmpmapOID("rttMonEchoAdminControlEnable", "1.3.6.1.4.1.9.9.42.1.2.2.1.8"); +snmpmapOID("rttMonEchoAdminTOS", "1.3.6.1.4.1.9.9.42.1.2.2.1.9"); +snmpmapOID("rttMonEchoAdminLSREnable", "1.3.6.1.4.1.9.9.42.1.2.2.1.10"); +snmpmapOID("rttMonEchoAdminTargetAddressString", "1.3.6.1.4.1.9.9.42.1.2.2.1.11"); +snmpmapOID("rttMonEchoAdminNameServer", "1.3.6.1.4.1.9.9.42.1.2.2.1.12"); +snmpmapOID("rttMonEchoAdminOperation", "1.3.6.1.4.1.9.9.42.1.2.2.1.13"); +snmpmapOID("rttMonEchoAdminHTTPVersion", "1.3.6.1.4.1.9.9.42.1.2.2.1.14"); +snmpmapOID("rttMonEchoAdminURL", "1.3.6.1.4.1.9.9.42.1.2.2.1.15"); +snmpmapOID("rttMonEchoAdminCache", "1.3.6.1.4.1.9.9.42.1.2.2.1.16"); +snmpmapOID("rttMonEchoAdminInterval", "1.3.6.1.4.1.9.9.42.1.2.2.1.17"); +snmpmapOID("rttMonEchoAdminNumPackets", "1.3.6.1.4.1.9.9.42.1.2.2.1.18"); +snmpmapOID("rttMonEchoAdminProxy", "1.3.6.1.4.1.9.9.42.1.2.2.1.19"); +snmpmapOID("rttMonEchoAdminString1", "1.3.6.1.4.1.9.9.42.1.2.2.1.20"); +snmpmapOID("rttMonEchoAdminString2", "1.3.6.1.4.1.9.9.42.1.2.2.1.21"); +snmpmapOID("rttMonEchoAdminString3", "1.3.6.1.4.1.9.9.42.1.2.2.1.22"); +snmpmapOID("rttMonEchoAdminString4", "1.3.6.1.4.1.9.9.42.1.2.2.1.231"); +snmpmapOID("rttMonEchoAdminString5", "1.3.6.1.4.1.9.9.42.1.2.2.1.24"); +snmpmapOID("rttMonEchoAdminMode", "1.3.6.1.4.1.9.9.42.1.2.2.1.25"); +snmpmapOID("rttMonEchoAdminVrfName", "1.3.6.1.4.1.9.9.42.1.2.2.1.26"); + +# cisco(9).ciscoMgmt(9).ciscoRttMonMIB(42).ciscoRttMonObjects(1).rttMonCtrl(2).rttMonScheduleAdminTable(5).rttMonScheduleAdminEntry(1) +snmpmapOID("rttMonScheduleAdminRttLife", "1.3.6.1.4.1.9.9.42.1.2.5.1.1"); +snmpmapOID("rttMonScheduleAdminRttStartTime", "1.3.6.1.4.1.9.9.42.1.2.5.1.2"); +snmpmapOID("rttMonScheduleAdminConceptRowAgeout", "1.3.6.1.4.1.9.9.42.1.2.5.1.3"); + +# cisco(9).ciscoMgmt(9).ciscoRttMonMIB(42).ciscoRttMonObjects(1).rttMonCtrl(2).rttMonScheduleAdminTable(5).rttMonScheduleAdminEntry(1) +snmpmapOID("rttMonScheduleAdminRttLife", "1.3.6.1.4.1.9.9.42.1.2.5.1.1"); + + +# cisco(9).ciscoMgmt(9).ciscoRttMonMIB(42).ciscoRttMonObjects(1).rttMonCtrl(2).rttMonHistoryAdminTable(8).rttMonHistoryAdminEntry(1) +snmpmapOID("rttMonHistoryAdminNumLives", "1.3.6.1.4.1.9.9.42.1.2.8.1.1"); +snmpmapOID("rttMonHistoryAdminNumBuckets", "1.3.6.1.4.1.9.9.42.1.2.8.1.2"); +snmpmapOID("rttMonHistoryAdminNumSamples", "1.3.6.1.4.1.9.9.42.1.2.8.1.3"); +snmpmapOID("rttMonHistoryAdminFilter", "1.3.6.1.4.1.9.9.42.1.2.8.1.4"); + +snmpmapOID("rttMonCtrlOperConnectionLostOccurred", "1.3.6.1.4.1.9.9.42.1.2.9.1.5"); +snmpmapOID("rttMonCtrlOperTimeoutOccurred", "1.3.6.1.4.1.9.9.42.1.2.9.1.6"); +snmpmapOID("rttMonCtrlOperOverThresholdOccurred", "1.3.6.1.4.1.9.9.42.1.2.9.1.7"); +snmpmapOID("rttMonCtrlOperNumRtts", "1.3.6.1.4.1.9.9.42.1.2.9.1.8"); +snmpmapOID("rttMonCtrlOperRttLife", "1.3.6.1.4.1.9.9.42.1.2.9.1.9"); +snmpmapOID("rttMonCtrlOperState", "1.3.6.1.4.1.9.9.42.1.2.9.1.10"); +snmpmapOID("rttMonCtrlOperVerifyErrorOccurred", "1.3.6.1.4.1.9.9.42.1.2.9.1.11"); + +# cisco(9).ciscoMgmt(9).ciscoRttMonMIB(42).ciscoRttMonObjects(1).rttMonHistory(4).rttMonHistoryCollectionTable(1).rttMonHistoryCollectionEntry(1) +snmpmapOID("rttMonStatisticsAdminNumPaths", "1.3.6.1.4.1.9.9.42.1.2.7.1.2"); +snmpmapOID("rttMonStatisticsAdminNumHops", "1.3.6.1.4.1.9.9.42.1.2.7.1.3"); + +# cisco(9).ciscoMgmt(9).ciscoRttMonMIB(42).ciscoRttMonObjects(1).rttMonHistory(4).rttMonHistoryCollectionTable(1).rttMonHistoryCollectionEntry(1) +snmpmapOID("rttMonHistoryCollectionLifeIndex", "1.3.6.1.4.1.9.9.42.1.4.1.1.1"); +snmpmapOID("rttMonHistoryCollectionBucketIndex", "1.3.6.1.4.1.9.9.42.1.4.1.1.2"); +snmpmapOID("rttMonHistoryCollectionSampleIndex", "1.3.6.1.4.1.9.9.42.1.4.1.1.3"); +snmpmapOID("rttMonHistoryCollectionSampleTime", "1.3.6.1.4.1.9.9.42.1.4.1.1.4"); +snmpmapOID("rttMonHistoryCollectionAddress", "1.3.6.1.4.1.9.9.42.1.4.1.1.5"); +snmpmapOID("rttMonHistoryCollectionCompletionTime", "1.3.6.1.4.1.9.9.42.1.4.1.1.6"); +snmpmapOID("rttMonHistoryCollectionSense", "1.3.6.1.4.1.9.9.42.1.4.1.1.7"); +snmpmapOID("rttMonHistoryCollectionApplSpecificSense", "1.3.6.1.4.1.9.9.42.1.4.1.1.8"); +snmpmapOID("rttMonHistoryCollectionSenseDescription", "1.3.6.1.4.1.9.9.42.1.4.1.1.9"); + + +# return 1 to indicate that all is ok.. +1; diff --git a/lib/matchers/avgratio.pm b/lib/matchers/avgratio.pm new file mode 100644 index 0000000..401845d --- /dev/null +++ b/lib/matchers/avgratio.pm @@ -0,0 +1,148 @@ +package matchers::avgratio; + +=head1 NAME + +matchers::avgratio - detect changes in average median latency + +=head1 OVERVIEW + +The avgratio matcher establishes a historic average median latency over +several measurement rounds. It compares this average, against a second +average latency value again build over several rounds of measurment. + +=head1 DESCRIPTION + +Call the matcher with the following sequence: + + type = matcher + pattern = avgratio(historic=>a,current=>b,comparator=>o,percentage=>p) + +=over + +=item historic + +The number of median values to use for building the 'historic' average. + +=item current + +The number of median values to use for building the 'current' average. + +=item comparator + +Which comparison operator should be used to compare current/historic with percentage. + +=item percentage + +Right hand side of the comparison. + +=back + + old <--- historic ---><--- current ---> now + +=head1 EXAMPLE + +Take build the average median latency over 10 samples, use this to divid the +current average latency built over 2 samples and check if it is bigger than +150%. + + avgratio(historic=>10,current=>2,comparator=>'>',percentage=>150); + + avg(current)/avg(historic) > 150/100 + +This means the matcher will activate when the current latency average if +more than 1.5 times the historic latency average established over the last +10 rounds of measurement. + +=head1 COPYRIGHT + +Copyright (c) 2004 by OETIKER+PARTNER AG. All rights reserved. + +=head1 SPONSORSHIP + +The development of this matcher has been sponsored by Virtela Communications www.virtela.net. + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +=head1 AUTHOR + +Tobias Oetiker <tobi@oetiker.ch> + +=cut + +use vars qw($VERSION); + + +$VERSION = 1.0; + +use strict; +use base qw(matchers::base); +use Carp; + +sub new(@) +{ + my $class = shift; + my $rules = { + historic=>'\d+', + current=>'\d+', + comparator=>'(<|>|<=|>=|==)', + percentage=>'\d+(\.\d+)?' }; + + my $self = $class->SUPER::new($rules,@_); + $self->{param}{sub} = eval "sub {\$_[0] ".$self->{param}{comparator}." \$_[1]}"; + croak "compiling comparator $self->{param}{comparator}: $@" if $@; + $self->{param}{value} = $self->{param}{percentage}/100; + return $self; +} + +sub Length($) +{ + my $self = shift; + return $self->{param}{historic} + $self->{param}{current}; +} + +sub Desc ($) { + croak "Detect changes in average median latency"; +} + +sub avg(@){ + my $sum=0; + my $cnt=0; + for (@_){ + next unless defined $_; + $sum += $_; + $cnt ++; + } + return $sum/$cnt if $cnt; + return undef; +} + +sub Test($$) +{ my $self = shift; + my $data = shift; # @{$data->{rtt}} and @{$data->{loss}} + my $len = $self->Length; + my $rlen = scalar @{$data->{rtt}}; + return undef + if $rlen < $len + or (defined $data->{rtt}[-$len] and $data->{rtt}[-$len] eq 'S'); + my $ac = $self->{param}{historic}; + my $bc = $self->{param}{current}; + my $cc = $ac +$bc; + my $ha = avg(@{$data->{rtt}}[-$cc..-$bc-1]); + my $ca = avg(@{$data->{rtt}}[-$bc..-1]); + return undef unless $ha and $ca; + return &{$self->{param}{sub}}($ca/$ha,$self->{param}{value}); +} diff --git a/lib/matchers/base.pm b/lib/matchers/base.pm new file mode 100644 index 0000000..3631655 --- /dev/null +++ b/lib/matchers/base.pm @@ -0,0 +1,127 @@ +package matchers::base; + +=head1 NAME + +matchers::base - Base Class for implementing SmokePing Matchers + +=head1 OVERVIEW + +This is the base class for writing SmokePing matchers. Every matcher must +inherit from the base class and provide it's own methods for the 'buisness' +logic. + +=head1 DESCRIPTION + +Every matcher must provide the following methods: + +=cut + +use vars qw($VERSION); +use Carp; + +$VERSION = 1.0; + +use strict; + +=head2 new + +The new method expects hash elements as an argument +eg new({x=>'\d+',y=>'\d+'},x=>1,y=>2). The first part is +a syntax rule for the arguments it should expect and the second part +are the arguments itself. The first part will be supplied +by the child class as it calls the partent method. + +=cut + +sub new(@) +{ + my $this = shift; + my $class = ref($this) || $this; + my $rules = shift; + my $self = { param => { @_ } }; + foreach my $key (keys %{$self->{param}}){ + my $regex = $rules->{$key}; + croak "key '$key' is not known byt this matcher" unless defined $rules->{$key}; + croak "key '$key' contains invalid data: '$self->{param}{$key}'" unless $self->{param}{$key} =~ m/^$regex$/; + } + bless $self, $class; + return $self; +} + +=head2 Length + +The Length method returns the number of values the +matcher will expect from SmokePing. This method must +be overridden by the children of the base class. + +=cut + +sub Length($) +{ + my $self = shift; + croak "SequenceLength must be overridden by the subclass"; +} + +=head2 Desc + +Simply return the description of the function. This method must +be overwritten by a children of the base class. + +=cut + + +sub Desc ($) { + croak "MatcherDesc must be overridden by the subclass"; +} + +=head2 Test + +Run the matcher and return true or false. The Test method is called +with a hash of two arrays giving it access to both rtt and loss values + + my $data=shift; + my @rtt = @{$data->{rtt}}; + my @loss = @{$data->{loss}}; + +The arrays are ordered from old to new. + + @rdd[old..new] + +There may be more than the expected number of elements in this array. Address them with +$x[-1] to $x[-max]. + + +=cut + +sub Test($$) +{ my $self = shift; + my $data = shift; # @{$data->{rtt}} and @{$data->{loss}} + croak "Match must be overridden by the subclass"; + +} + +=head1 COPYRIGHT + +Copyright (c) 2004 by OETIKER+PARTNER AG. All rights reserved. + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +=head1 AUTHOR + +Tobias Oetiker <tobi@oetiker.ch> + +=cut diff --git a/lib/matchers/median.pm b/lib/matchers/median.pm new file mode 100644 index 0000000..6b17bff --- /dev/null +++ b/lib/matchers/median.pm @@ -0,0 +1,80 @@ +package matchers::median; + +=head1 NAME + +matchers::median - Find persistant change in latency + +=head1 OVERVIEW + +The idea behind this matcher is to find sustained changes in latency. + +The median matcher takes a number of past median latencies. It splits the latencies into +two groups (old and new) and again finds the median for each groups. If the +difference between the two medians is bigger than a certain value, it will +give a match. + +=head1 DESCRIPTION + +Call the matcher with the following sequence: + + type = matcher + pattern = median(old=>x,new=>y,diff=>z) + +This will create a matcher which consumes x+y latency-datapoints, builds the +two medians and the matches if the difference between the median latency is +larger than z seconds. + +=head1 COPYRIGHT + +Copyright (c) 2004 by OETIKER+PARTNER AG. All rights reserved. + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +=head1 AUTHOR + +Tobias Oetiker <tobi@oetiker.ch> + +=cut + +use strict; +use base qw(matchers::base); +use vars qw($VERSION); +$VERSION = 1.0; +use Carp; + +# how many values does the matcher need to do it's magic +sub Length($) +{ + my $self = shift; + return $self->{param}{old} + $self->{param}{new}; +} + +sub Desc ($) { + croak "Finde changes in median latency"; +} + +sub Test($$) +{ my $self = shift; + my $data = shift; # @{$data->{rtt}} and @{$data->{loss}} + my $ac = $self->{param}{old}; + my $bc = $self->{param}{new}; + my $cc = $ac +$bc; + my $oldm = (sort {$a <=> $b} @{$data->{rtt}}[-$cc..-$bc-1])[int($a/2)]; + $ac++; + my $newm = (sort {$a <=> $b} @{$data->{rtt}}[-$bc..-1])[int($bc/2)]; + return abs($oldm-$newm) > $self->{param}{diff}; +} diff --git a/lib/probes/AnotherDNS.pm b/lib/probes/AnotherDNS.pm new file mode 100644 index 0000000..7acc36d --- /dev/null +++ b/lib/probes/AnotherDNS.pm @@ -0,0 +1,156 @@ +package probes::AnotherDNS; + +=head1 NAME + +probes::AnotherDNS - Alternate DNS Probe + +=head1 SYNOPSIS + + *** Probes *** + + AnotherDNS + + *** Targets *** + probe = AnotherDNS + forks = 10 + + + First + menu = First + title = First Target + # .... + + ++ PROBE_CONF + lookup = www.mozilla.org + +=head1 DESCRIPTION + +Like DNS, but uses Net::DNS and Time::HiRes instead of dig. This probe does +*not* retry the request three times before it is considerd "lost", like dig and +other resolver do by default. If operating as caching Nameserver, BIND (and +maybe others) expect clients to retry the request if the answer is not in the +cache. So, ask the nameserver for something that he is authorative for if you +want measure the network packet loss correctly. + +If you have a really fast network and nameserver, you will notice that this +probe reports the query time in microsecond resolution. :-) + +=over + +=item forks + +The number of concurrent processes to be run. See probes::basefork(3pm) +for details. + +=back + +Supported target-level probe variables: + +=over + +=item lookup + +Name of the host to look up in the dns. + +=item sleeptime + +Time to sleep between two lookups in microseconds. Default is 500000. + +=item recordtype + +Record type to look up. Default is "A". + +=item timeout + +Timeout for a single request in seconds. Default is 5. + +=item port + +UDP Port to use. Default is 53. (Surprise!) + +=back + + +=head1 AUTHOR + +Christoph Heine E<lt>Christoph.Heine@HaDiKo.DEE<gt> + +=cut + +use strict; + +# And now, an extra ugly hack +# Reason: Net::DNS does an eval("use Win32:Registry") to +# find out if it is running on Windows. This triggers the signal +# handler in the cgi mode. + +my $tmp = $SIG{__DIE__}; +$SIG{__DIE__} = sub { }; +eval("use Net::DNS;"); +$SIG{__DIE__} = $tmp; + +use base qw(probes::basefork); +use IPC::Open3; +use Symbol; +use Carp; +use Time::HiRes qw(usleep ualarm gettimeofday tv_interval); +use IO::Socket; +use IO::Select; + +sub new($$$) { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + return $self; +} + +sub ProbeDesc($) { + my $self = shift; + return "DNS requests"; +} + +sub pingone ($) { + my $self = shift; + my $target = shift; + + my $host = $target->{addr}; + my $lookuphost = $target->{vars}{lookup}; + my $sleeptime = $target->{vars}{sleeptime}; + my $recordtype = $target->{vars}{recordtype}; + my $timeout = $target->{vars}{timeout}; + my $port = $target->{vars}{port}; + $recordtype = "A" unless defined $recordtype; + $timeout = 5 unless defined $timeout; + $port = 53 unless defined $port; + $sleeptime = 500000 unless defined $sleeptime; + $lookuphost = $target->{addr} unless defined $lookuphost; + + my $packet = Net::DNS::Packet->new( $lookuphost, $recordtype )->data; + my $sock = IO::Socket::INET->new( + "PeerAddr" => $host, + "PeerPort" => $port, + "Proto" => "udp", + ); + my $sel = IO::Select->new($sock); + + my @times; + + for ( my $run = 0 ; $run < $self->pings($target) ; $run++ ) { + my $t0 = [gettimeofday]; + $sock->send($packet); + my ($ready) = $sel->can_read($timeout); + my $t1 = [gettimeofday]; + if ( defined $ready ) { + my $time = tv_interval( $t0, $t1 ); + push @times, $time; + my $buf = ''; + $ready->recv( $buf, &Net::DNS::PACKETSZ ); + } + usleep($sleeptime); + } + @times = + map { sprintf "%.10e", $_ } sort { $a <=> $b } grep { $_ ne "-" } @times; + + return @times; +} + +1; + diff --git a/lib/probes/AnotherSSH.pm b/lib/probes/AnotherSSH.pm new file mode 100644 index 0000000..bb1a8bb --- /dev/null +++ b/lib/probes/AnotherSSH.pm @@ -0,0 +1,234 @@ +package probes::AnotherSSH; + +=head1 NAME + +probes::AnotherSSH - Another SSH probe + +=head1 SYNOPSIS + + *** Probes *** + + AnotherSSH + + *** Targets *** + probe = AnotherSSH + forks = 10 + + + First + menu = First + title = First Target + # .... + + ++ PROBE_CONF + greeting = SSH-Latecy-Measurement-Sorry-for-the-logfile-entry + sleeptime = 500000 + interval = established + timeout = 5 + +=head1 DESCRIPTION + +Latency measurement using SSH. This generates Logfile messages on the other +Host, so get permission from the owner first! + +=over + +=item forks + +The number of concurrent processes to be run. See probes::basefork(3pm) +for details. + +=back + +Supported target-level probe variables: + +=over + +=item greeting + +Greeting string to send to the SSH Server. This will appear in the Logfile. +Use this to make clear, who you are and what you are doing to avoid confusion. + +Also, don't use something that is a valid version string. This probe assumes +that the connection gets terminated because of protocol mismatch. + +=item sleeptime + +Time to sleep between two measurements in microsends. Default is 500000. + +=item interval + +The interval to measure + +=over + +=item connect + +Interval between connect() and the greeting string from the host. + +=item established + +Interval between our greeting message and the end of the connection +because of Protocol mismatch. This is the default. + +=item complete + +From connect() to the end of the connection. + +=back + +=item timeout + +Timeout for the connection. Default is 5. + +=item port + +Connect to this port. Default is 22. + +=back + + +=head1 AUTHOR + +Christoph Heine E<lt>Christoph.Heine@HaDiKo.DEE<gt> + +=cut + +use strict; +use base qw(probes::basefork); +use Carp; +use Time::HiRes qw(usleep ualarm gettimeofday tv_interval); +use IO::Select; +use Socket; +use Fcntl; + + +sub new($$$) { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + return $self; +} + +sub ProbeDesc($) { + my $self = shift; + return "SSH connections"; +} + +sub pingone ($) { + my $self = shift; + my $target = shift; + + my $host = $target->{addr}; + + # Time + my $sleeptime = $target->{vars}{sleeptime}; + $sleeptime = 500000 unless defined $sleeptime; + + # Our greeting string. + my $greeting = $target->{vars}{greeting}; + $greeting = "SSH-Latency-Measurement-Sorry-for-this-logmessage" + unless defined $greeting; + + # Interval to measure + my $interval = $target->{vars}{interval}; + $interval = "established" unless defined $interval; + if(not ( $interval eq "connect" or $interval eq "established" or $interval eq "complete")) { + $self->do_debug("Invalid interval parameter"); + return undef; + } + + # Connect to this port. + my $port = $target->{vars}{port}; + $port = 22 unless defined $port; + + #Timeout for the select() calls. + my $timeout = $target->{vars}{timeout}; + $timeout = 5 unless defined $timeout; + + my @times; # Result times + + for ( my $run = 0 ; $run < $self->pings($target) ; $run++ ) { + my ($t0,$t1,$t2,$t3); # Timestamps. + + #Temporary variables to play with. + my $ready; + my $buf; + my $nbytes; + + my $proto = getprotobyname('tcp'); + my $iaddr = gethostbyname($host); + my $sin = sockaddr_in( $port, $iaddr ); + socket( Socket_Handle, PF_INET, SOCK_STREAM, $proto ); + + # Make the Socket non-blocking + my $flags = fcntl( Socket_Handle, F_GETFL, 0 ) or do { + $self->do_debug("Can't get flags for socket: $!"); + close(Socket_Handle); + next; + }; + + fcntl( Socket_Handle, F_SETFL, $flags | O_NONBLOCK ) or do { + $self->do_debug("Can't make socket nonblocking: $!"); + close(Socket_Handle); next; + }; + + my $sel = IO::Select->new( \*Socket_Handle ); + + # connect () and measure the Time. + $t0 = [gettimeofday]; + connect( Socket_Handle, $sin ); + ($ready) = $sel->can_read($timeout); + $t1 = [gettimeofday]; + + if(not defined $ready) { + $self->do_debug("Timeout!"); + close(Socket_Handle); next; + } + $nbytes = sysread( Socket_Handle, $buf, 1500 ); + if ($nbytes <= 0) { + $self->do_debug("Read nothing and Connection closed!"); + close(Socket_Handle); next; + } + # $self->do_debug("Got '$buf' from remote Server"); + if (not $buf =~ m/^SSH/) { + $self->do_debug("Not an SSH Server"); + close(Socket_Handle); next; + } + + ($ready) = $sel->can_write($timeout); + if (not defined($ready)) { + $self->do_debug("Huh? Can't write."); + close(Socket_Handle); next; + } + $t2 = [gettimeofday]; + syswrite( Socket_Handle, $greeting . "\n" ); + ($ready) = $sel->can_read($timeout); + $t3 = [gettimeofday]; + if(not defined $ready) { + $self->do_debug("Timeout!"); + close(Socket_Handle); next; + } + close(Socket_Handle); + + # We made it! Yeah! + + if( $interval eq "connect") { + push @times, tv_interval( $t0, $t1 ); + } elsif ( $interval eq "established") { + push @times, tv_interval($t2,$t3); + } elsif ($interval eq "complete") { + push @times, tv_interval($t0,$t3); + } else { + $self->do_debug("You should never see this message.\n The universe will now collapse. Goodbye!\n"); + } + + + usleep($sleeptime); + } + @times = + map { sprintf "%.10e", $_ } sort { $a <=> $b } grep { $_ ne "-" } @times; + + return @times; +} + +1; + diff --git a/lib/probes/CiscoRTTMonDNS.pm b/lib/probes/CiscoRTTMonDNS.pm new file mode 100644 index 0000000..829a4de --- /dev/null +++ b/lib/probes/CiscoRTTMonDNS.pm @@ -0,0 +1,283 @@ +package probes::CiscoRTTMonDNS; + +# please use +# pod2man CiscoRTTMonDNS.pm | nroff -man | more +# to view the manpage of this document +# + + +=head1 NAME + +probes::CiscoRTTMonDNS.pm - Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + CiscoRTTMonDNS + + forks=50 + + *** Targets *** + + MyRouter-DNSserver + menu = MyRouter->DNSserver + title = RTTMon DNS lookup of www.foobar.com.au on DNSserver + host = DNSserver.foobar.com.au + probe=CiscoRTTMonDNS + ++ PROBE_CONF + ioshost = RTTcommunity@Myrouter.foobar.com.au + name=www.foobar.com.au + iosint = 10.33.22.11 + +=head1 DESCRIPTION + +A probe for smokeping, which uses the ciscoRttMon MIB functionality ("Service Assurance Agent", "SAA") of Cisco IOS to time ( recursive, type A) DNS queries to a DNS server. + +=head1 PARAMETERS + +The (mandatory) host parameter specifies the DNS server, which the router will use. This can be a DNS name, the smokeping host can resolve or a dotted-quad IP address. + +The (mandatory) ioshost parameter specifies the Cisco router, which will send the DNS requests, as well as the SNMP community string on the router. + +The (mandatory) name parameter is the DNS name to resolve. + +The (optional) iosint parameter is the source address for the DNS packets. This should be one of the active (!) IP addresses of the router to get results. IOS looks up the target host address in the forwarding table and then uses the interface(s) listed there to send the DNS packets. By default IOS uses the (primary) IP address on the sending interface as source address for packets originated by the router. + +=head1 IOS VERSIONS + +This probe only works with IOS 12.0(3)T or higher. It is recommended to test it on less critical routers first. + +=head1 INSTALLATION + +To install this probe copy ciscoRttMonMIB.pm to ($SMOKEPINGINSTALLDIR)/lib and CiscoRTTMonDNS.pm to ($SMOKEPINGINSTALLDIR)/lib/probes. + +The router(s) must be configured to allow read/write SNMP access. Sufficient is: + + snmp-server community RTTCommunity RW + +If you want to be a bit more restrictive with SNMP write access to the router, then consider configuring something like this + + access-list 2 permit 10.37.3.5 + snmp-server view RttMon ciscoRttMonMIB included + snmp-server community RTTCommunity view RttMon RW 2 + +The above configuration grants SNMP read-write only to 10.37.3.5 (the smokeping host) and only to the ciscoRttMon MIB tree. The probe does not need access to SNMP variables outside the RttMon tree. + +=head1 BUGS + +The probe does unnecessary DNS queries, i.e. more than configured in the "pings" variable, because the RTTMon MIB only allows to set a total time for all queries in one measurement run (one "life"). Currently the probe sets the life duration to "pings"*2+3 seconds (2 secs is the timeout value hardcoded into this probe). + +=head1 SEE ALSO + +http://people.ee.ethz.ch/~oetiker/webtools/smokeping/ +http://www.switch.ch/misc/leinen/snmp/perl/ + +The best source for background info on SAA is Cisco's documentation on http://www.cisco.com and the CISCO-RTTMON-MIB documentation, which is available at: +ftp://ftp.cisco.com/pub/mibs/v2/CISCO-RTTMON-MIB.my + + + +=head1 AUTHOR + +Joerg.Kummer at Roche.com + +=cut + +use strict; +use base qw(probes::basefork); +use Symbol; +use Carp; +use BER; +use SNMP_Session; +use SNMP_util "0.97"; +use ciscoRttMonMIB "0.2"; + +my $pingtimeout =2; + +sub new($$$) +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ( $ENV{SERVER_SOFTWARE} ) { + $self->{pingfactor} = 1000; + }; + return $self; +} + +sub ProbeDesc($){ + my $self = shift; + my $bytes = $self->{properties}{packetsize} || 56; + return "CiscoRTTMonDNS.pm"; +} + +sub pingone ($$) { + my $self = shift; + my $target = shift; + + croak ("please define 'ioshost' under the PROBE_CONF section of your target\n") + unless defined $target->{vars}{ioshost} ; + + croak ("please define 'name' under the PROBE_CONF section of your target\n") + unless defined $target->{vars}{name} ; + my $name = $target->{vars}{name}; + + my $pings = $self->pings($target) || 20; + + # use the proces ID as as row number to make this poll distinct on the router; + my $row=$$; + + if (defined + StartRttMibEcho($target->{vars}{ioshost}.":::::2", $target->{addr}, $name, + $pings, $target->{vars}{iosint}, $row)) + { + # wait for the series to finish + sleep ($pings*$pingtimeout+5); + if (my @times=FillTimesFromHistoryTable($target->{vars}{ioshost}.":::::2", $pings, $row)){ + DestroyData ($target->{vars}{ioshost}.":::::2", $row); + return @times; + } + else { + return(); + } + } + else { + return (); + } +} + +sub StartRttMibEcho ($$$$$$){ + my ($host, $target, $dnsName, $pings, $sourceip, $row) = @_; + + # resolve the target name and encode its IP address + $_=$target; + if (!/^([0-9]|\.)+/) { + (my $name, my $aliases, my $addrtype, my $length, my @addrs) = gethostbyname ($target); + $target=join('.',(unpack("C4",$addrs[0]))); + } + my @octets=split(/\./,$target); + my $encoded_target= pack ("CCCC", @octets); + + # resolve the source name and encode its IP address + my $encoded_source = undef; + if (defined $sourceip) { + $_=$sourceip; + if (!/^([0-9]|\.)+/) { + (my $name, my $aliases, my $addrtype, my $length, my @addrs) = gethostbyname ($sourceip); + $sourceip=join('.',(unpack("C4",$addrs[0]))); + } + my @octets=split(/\./,$sourceip); + $encoded_source= pack ("CCCC", @octets); + } + + ############################################################# + # rttMonCtrlAdminStatus - 1:active 2:notInService 3:notReady 4:createAndGo 5:createAndWait 6:destroy + #delete data from former measurements + #return undef unless defined + # &snmpset($host, "rttMonCtrlAdminStatus.$row",'integer', 6); + + ############################################################# + # Check RTTMon version and supported protocols + $SNMP_Session::suppress_warnings = 10; # be silent + (my $version)=&snmpget ($host, "rttMonApplVersion"); + if (! defined $version ) { + Smokeping::do_log ("$host doesn't support or allow RTTMon !\n"); + return undef; + } + Smokeping::do_log ("$host supports $version\n"); + $SNMP_Session::suppress_warnings = 0; # report errors + + # echo(1), pathEcho(2), fileIO(3), script(4), udpEcho(5), tcpConnect(6), http(7), + # dns(8), jitter(9), dlsw(10), dhcp(11), ftp(12) + + my $DnsSupported=0==1; + snmpmaptable ($host, + sub () { + my ($proto, $supported) = @_; + # 1 is true , 2 is false + $DnsSupported=0==0 if ($proto==8 && $supported==1); + }, + "rttMonApplSupportedRttTypesValid"); + + if (! $DnsSupported) { + Smokeping::do_log ("$host doesn't support DNS resolution time measurements !\n"); + return undef; + } + + + ############################################################# + #setup the new data row + + my @params=(); + push @params, + "rttMonCtrlAdminStatus.$row", 'integer', 5, + "rttMonCtrlAdminRttType.$row", 'integer', 8, + "rttMonEchoAdminProtocol.$row", 'integer', 26, + "rttMonEchoAdminNameServer.$row", 'octetstring', $encoded_target, + "rttMonEchoAdminTargetAddressString.$row",'octetstring', $dnsName, + "rttMonCtrlAdminTimeout.$row", 'integer', $pingtimeout*1000, + "rttMonCtrlAdminFrequency.$row", 'integer', $pingtimeout, + "rttMonCtrlAdminNvgen.$row", 'integer', 2, + "rttMonHistoryAdminNumBuckets.$row", 'integer', $pings, + "rttMonHistoryAdminNumLives.$row", 'integer', 1, + "rttMonHistoryAdminFilter.$row", 'integer', 2, + "rttMonScheduleAdminRttStartTime.$row", 'timeticks', 1, + "rttMonScheduleAdminRttLife.$row", 'integer', $pings*$pingtimeout+3, + "rttMonScheduleAdminConceptRowAgeout.$row",'integer', 60; + + # the router (or this script) doesn't check whether the IP address is one of + # the router's IP address, i.e. the router might send packets, but never + # gets replies.. + if (defined $sourceip) { + push @params, "rttMonEchoAdminSourceAddress.$row", 'octetstring', $encoded_source; + } + + return undef unless defined + &snmpset($host, @params); + + ############################################################# + # and go ! + return undef unless defined + &snmpset($host, "rttMonCtrlAdminStatus.$row",'integer',1); + + return 1; +} + + +# RttResponseSense values +# 1:ok 2:disconnected 3:overThreshold 4:timeout 5:busy 6:notConnected 7:dropped 8:sequenceError +# 9:verifyError 10:applicationSpecific 11:dnsServerTimeout 12:tcpConnectTimeout 13:httpTransactionTimeout +#14:dnsQueryError 15:httpError 16:error + +sub FillTimesFromHistoryTable($$$$) { + my ($host, $pings, $row) = @_; + my @times; + + # snmpmaptable walks two tables (of equal size) + # - "rttMonHistoryCollectionCompletionTime.$row", + # - "rttMonHistoryCollectionSense.$row" + # The code in the sub() argument is executed for each index value snmptable walks + + snmpmaptable ($host, + sub () { + my ($index, $rtt, $status) = @_; + push @times, (sprintf ("%.10e", $rtt/1000)) + if ($status==1); + }, + "rttMonHistoryCollectionCompletionTime.$row", + "rttMonHistoryCollectionSense.$row"); + + return sort { $a <=> $b } @times; +} + +sub DestroyData ($$) { + my ($host, $row) = @_; + + &snmpset($host, "rttMonCtrlOperState.$row", 'integer', 3); + &snmpset($host, "rttMonCtrlAdminStatus.$row", 'integer', 2); + #delete any old config + &snmpset($host, "rttMonCtrlAdminStatus.$row", 'integer', 6); +} + +1; + diff --git a/lib/probes/CiscoRTTMonEchoICMP.pm b/lib/probes/CiscoRTTMonEchoICMP.pm new file mode 100644 index 0000000..9871813 --- /dev/null +++ b/lib/probes/CiscoRTTMonEchoICMP.pm @@ -0,0 +1,289 @@ +package probes::CiscoRTTMonEchoICMP; + +# please use +# pod2man CiscoRTTMonEchoICMP.pm | nroff -man | more +# to view the manpage of this document +# + + +=head1 NAME + +probes::CiscoRTTMonEchoICMP - Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + CiscoRTTMonEchoICMP + + forks=50 + + *** Targets *** + + MyRouter-PingVictim + menu = MyRouter->PingVictim + title = RTTMon ping from MyRouter to PingVictim + host = PingVictim.foobar.com.au + ++ PROBE_CONF + ioshost = RTTcommunity@Myrouter.foobar.com.au + iosint = 10.33.22.11 + packetsize = 1024 + tos = 160 + +=head1 DESCRIPTION + +A probe for smokeping, which uses the ciscoRttMon MIB functionality ("Service Assurance Agent", "SAA") of Cisco IOS to measure ICMP echo ("ping") roundtrip times between a Cisco router and any IP address. + +=head1 PARAMETERS + +The (mandatory) host parameter specifies the IP host, which will be pinged by the router. This can be a DNS name, the smokeping host can resolve or a dotted-quad IP address. + +The (mandatory) ioshost parameter specifies the Cisco router, which will execute the pings, as well as the SNMP community string on the router. + +The (optional) packetsize parameter lets you configure the packetsize for the pings sent. The minimum is 8, the maximum 16392. Use the same number as with fping, if you want the same packet sizes being used on the network. Please note that the packesize must be specified under PROBE_CONF, all other definitions will be ignored. Default is 56 bytes. + +The (optional) iosint parameter is the source address for the pings sent. This should be one of the active (!) IP addresses of the router to get results. IOS looks up the target host address in the forwarding table and then uses the interface(s) listed there to send the ping packets. By default IOS uses the (primary) IP address on the sending interface as source address for a ping. The RTTMon MIB versions before IOS 12.0(3)T didn't support this parameter. + +The (optional) tos parameter specifies the value of the ToS byte in the IP header of the pings. Multiply DSCP values times 4 and Precedence values times 32 to calculate the ToS values to configure, e.g. ToS 160 corresponds to a DSCP value 40 and a Precedence value of 5. The RTTMon MIB versions before IOS 12.0(3)T didn't support this parameter. + +=head1 IOS VERSIONS + +It is highly recommended to use this probe with routers running IOS 12.0(3)T or higher and to test it on less critical routers first. I managed to crash a router with 12.0(9) quite consistently ( in IOS lingo 12.0(9) is older code than 12.0(3)T ). I did not observe crashes on higher IOS releases, but messages on the router like the one below, when multiple processes concurrently accessed the same router (this case was IOS 12.1(12b) ): + +Aug 20 07:30:14: %RTT-3-SemaphoreBadUnlock: %RTR: Attempt to unlock semaphore by wrong RTR process 70, locked by 78 + +Aug 20 07:35:15: %RTT-3-SemaphoreInUse: %RTR: Could not obtain a lock for RTR. Process 80 + + +=head1 INSTALLATION + +To install this probe copy ciscoRttMonMIB.pm files to ($SMOKEPINGINSTALLDIR)/lib and CiscoRTTMonEchoICMP.pm to ($SMOKEPINGINSTALLDIR)/lib/probes. V0.97 or higher of Simon Leinen's SNMP_Session.pm is required. + +The router(s) must be configured to allow read/write SNMP access. Sufficient is: + + snmp-server community RTTCommunity RW + +If you want to be a bit more restrictive with SNMP write access to the router, then consider configuring something like this + + access-list 2 permit 10.37.3.5 + snmp-server view RttMon ciscoRttMonMIB included + snmp-server community RTTCommunity view RttMon RW 2 + +The above configuration grants SNMP read-write only to 10.37.3.5 (the smokeping host) and only to the ciscoRttMon MIB tree. The probe does not need access to SNMP variables outside the RttMon tree. + +=head1 BUGS + +The probe sends unnecessary pings, i.e. more than configured in the "pings" variable, because the RTTMon MIB only allows to set a total time for all pings in one measurement run (one "life"). Currently the probe sets the life duration to "pings"*2+3 seconds (2 secs is the ping timeout value hardcoded into this probe). + +=head1 SEE ALSO + +http://people.ee.ethz.ch/~oetiker/webtools/smokeping/ +http://www.switch.ch/misc/leinen/snmp/perl/ + +The best source for background info on SAA is Cisco's documentation on http://www.cisco.com and the CISCO-RTTMON-MIB documentation, which is available at: +ftp://ftp.cisco.com/pub/mibs/v2/CISCO-RTTMON-MIB.my + + + +=head1 AUTHOR + +Joerg.Kummer at Roche.com + +=cut + +use strict; +use base qw(probes::basefork); +use Symbol; +use Carp; +use BER; +use SNMP_Session; +use SNMP_util "0.97"; +use ciscoRttMonMIB "0.2"; + +my $pingtimeout =2; + +sub new($$$) +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ( $ENV{SERVER_SOFTWARE} ) { + $self->{pingfactor} = 1000; + }; + return $self; +} + +sub ProbeDesc($){ + my $self = shift; + my $bytes = $self->{properties}{packetsize} || 56; + return "CiscoRTTMonEchoICMP ($bytes Bytes)"; +} + +sub pingone ($$) { + my $self = shift; + my $target = shift; + + croak ("please define 'ioshost' under the PROBE_CONF section of your target\n") + unless defined $target->{vars}{ioshost} ; + + my $pings = $self->pings($target) || 20; + my $tos = $target->{vars}{tos} || 0; + my $bytes = $target->{vars}{packetsize} || 56; + + # use the proces ID as as row number to make this poll distinct on the router; + my $row=$$; + + if (defined + StartRttMibEcho($target->{vars}{ioshost}.":::::2", $target->{addr}, + $bytes, $pings, $target->{vars}{iosint}, $tos, $row)) + { + # wait for the series to finish + sleep ($pings*$pingtimeout+5); + if (my @times=FillTimesFromHistoryTable($target->{vars}{ioshost}.":::::2", $pings, $row)){ + DestroyData ($target->{vars}{ioshost}.":::::2", $row); + return @times; + } + else { + return(); + } + } + else { + return (); + } +} + +sub StartRttMibEcho ($$$$$$){ + my ($host, $target, $size, $pings, $sourceip, $tos, $row) = @_; + + # resolve the target name and encode its IP address + $_=$target; + if (!/^([0-9]|\.)+/) { + (my $name, my $aliases, my $addrtype, my $length, my @addrs) = gethostbyname ($target); + $target=join('.',(unpack("C4",$addrs[0]))); + } + my @octets=split(/\./,$target); + my $encoded_target= pack ("CCCC", @octets); + + # resolve the source name and encode its IP address + my $encoded_source = undef; + if (defined $sourceip) { + $_=$sourceip; + if (!/^([0-9]|\.)+/) { + (my $name, my $aliases, my $addrtype, my $length, my @addrs) = gethostbyname ($sourceip); + $sourceip=join('.',(unpack("C4",$addrs[0]))); + } + my @octets=split(/\./,$sourceip); + $encoded_source= pack ("CCCC", @octets); + } + + ############################################################# + # rttMonCtrlAdminStatus - 1:active 2:notInService 3:notReady 4:createAndGo 5:createAndWait 6:destroy + #delete data from former measurements + #return undef unless defined + # &snmpset($host, "rttMonCtrlAdminStatus.$row",'integer', 6); + + ############################################################# + # Check RTTMon version and supported protocols + $SNMP_Session::suppress_warnings = 10; # be silent + (my $version)=&snmpget ($host, "rttMonApplVersion"); + if (! defined $version ) { + Smokeping::do_log ("$host doesn't support or allow RTTMon !\n"); + return undef; + } + Smokeping::do_log ("$host supports $version\n"); + $SNMP_Session::suppress_warnings = 0; # report errors + + # echo(1), pathEcho(2), fileIO(3), script(4), udpEcho(5), tcpConnect(6), http(7), + # dns(8), jitter(9), dlsw(10), dhcp(11), ftp(12) + my $udpEchoSupported=0==1; + snmpmaptable ($host, + sub () { + my ($proto, $supported) = @_; + # 1 is true , 2 is false + $udpEchoSupported=0==0 if ($proto==5 && $supported==1); + }, + "rttMonApplSupportedRttTypesValid"); + + ############################################################# + #setup the new data row + + my @params=(); + push @params, + "rttMonCtrlAdminStatus.$row", 'integer', 5, + "rttMonCtrlAdminRttType.$row", 'integer', 1, + "rttMonEchoAdminProtocol.$row", 'integer', 2, + "rttMonEchoAdminTargetAddress.$row", 'octetstring', $encoded_target, + "rttMonCtrlAdminTimeout.$row", 'integer', $pingtimeout*1000, + "rttMonCtrlAdminFrequency.$row", 'integer', $pingtimeout, + "rttMonHistoryAdminNumBuckets.$row", 'integer', $pings, + "rttMonHistoryAdminNumLives.$row", 'integer', 1, + "rttMonHistoryAdminFilter.$row", 'integer', 2, + "rttMonEchoAdminPktDataRequestSize.$row",'integer', $size-8, + "rttMonScheduleAdminRttStartTime.$row", 'timeticks', 1, + "rttMonScheduleAdminRttLife.$row", 'integer', $pings*$pingtimeout+3, + "rttMonScheduleAdminConceptRowAgeout.$row",'integer', 60; + + # with udpEcho support (>= 12.0(3)T ) the ICMP ping support was enhanced in the RTTMon SW - we are + # NOT using udpEcho, but echo (ICMP echo, ping) + if ($udpEchoSupported) { + push @params, "rttMonEchoAdminTOS.$row", 'integer', $tos; + push @params, "rttMonCtrlAdminNvgen.$row", 'integer', 2; + + # the router (or this script) doesn't check whether the IP address is one of + # the router's IP address, i.e. the router might send packets, but never + # gets ping replies.. + if (defined $sourceip) { + push @params, "rttMonEchoAdminSourceAddress.$row", 'octetstring', $encoded_source; + } + } + else { + Smokeping::do_log ("Warning this host does not support ToS or iosint\n"); + } + + return undef unless defined + &snmpset($host, @params); + + ############################################################# + # and go ! + return undef unless defined + &snmpset($host, "rttMonCtrlAdminStatus.$row",'integer',1); + + return 1; +} + + +# RttResponseSense values +# 1:ok 2:disconnected 3:overThreshold 4:timeout 5:busy 6:notConnected 7:dropped 8:sequenceError +# 9:verifyError 10:applicationSpecific 11:dnsServerTimeout 12:tcpConnectTimeout 13:httpTransactionTimeout +#14:dnsQueryError 15:httpError 16:error + +sub FillTimesFromHistoryTable($$$$) { + my ($host, $pings, $row) = @_; + my @times; + + # snmpmaptable walks two tables (of equal size) + # - "rttMonHistoryCollectionCompletionTime.$row", + # - "rttMonHistoryCollectionSense.$row" + # The code in the sub() argument is executed for each index value snmptable walks + snmpmaptable ($host, + sub () { + my ($index, $rtt, $status) = @_; + push @times, (sprintf ("%.10e", $rtt/1000)) + if ($status==1); + }, + "rttMonHistoryCollectionCompletionTime.$row", + "rttMonHistoryCollectionSense.$row"); + + return sort { $a <=> $b } @times; +} + +sub DestroyData ($$) { + my ($host, $row) = @_; + + &snmpset($host, "rttMonCtrlOperState.$row", 'integer', 3); + &snmpset($host, "rttMonCtrlAdminStatus.$row", 'integer', 2); + #delete any old config + &snmpset($host, "rttMonCtrlAdminStatus.$row", 'integer', 6); +} + +1; + diff --git a/lib/probes/CiscoRTTMonTcpConnect.pm b/lib/probes/CiscoRTTMonTcpConnect.pm new file mode 100644 index 0000000..c0b07bf --- /dev/null +++ b/lib/probes/CiscoRTTMonTcpConnect.pm @@ -0,0 +1,285 @@ +package probes::CiscoRTTMonTcpConnect; + +# please use +# pod2man CiscoRTTMonTcpConnect.pm | nroff -man | more +# to view the manpage of this document +# + + +=head1 NAME + +probes::CiscoRTTMonTcpConnect - Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + CiscoRTTMonTcpConnect + + forks=50 + + *** Targets *** + + MyRouter-TCPVictim + menu = MyRouter->TCPVictim + title = RTTMon TCP connect from MyRouter to TCPVictim + host = TCPVictim.foobar.com.au + probe=CiscoRTTMonTcpConnect + ++ PROBE_CONF + ioshost = RTTcommunity@Myrouter.foobar.com.au + iosint = 10.33.22.11 + tos = 160 + port = 23 + +=head1 DESCRIPTION + +A probe for smokeping, which uses the ciscoRttMon MIB functionality ("Service Assurance Agent", "SAA") of Cisco IOS to measure TCP connect times between a Cisco router and a TCP server. The measured value is the time is the time to establish a TCP session, i.e. the time between the initial "SYN" TCP packet of the router and the "SYN ACK" packet of the host. The router terminates the TCP session immediately after the reception of "SYN ACK" with a "FIN" packet. + +=head1 PARAMETERS + +The (mandatory) host parameter specifies the IP host, which the router will connect to. This can be a DNS name, the smokeping host can resolve or a dotted-quad IP address. + +The (mandatory) ioshost parameter specifies the Cisco router, which will establish the TCP connections as well as the SNMP community string on the router. + +The (optional) port parameter lets you configure the destination TCP port on the host. The default is the http port 80. + +The (optional) iosint parameter is the source address for the TCP connections. This should be one of the active (!) IP addresses of the router to get results. IOS looks up the target host address in the forwarding table and then uses the interface(s) listed there to send the TCP packets. By default IOS uses the (primary) IP address on the sending interface as source address for a connection. + +The (optional) tos parameter specifies the value of the ToS byte in the IP header of the packets from the router. Multiply DSCP values times 4 and Precedence values times 32 to calculate the ToS values to configure, e.g. ToS 160 corresponds to a DSCP value 40 and a Precedence value of 5. Please note that this will not influence the ToS value in the packets sent by the the host. + +=head1 IOS VERSIONS + +This probe only works with Cisco IOS 12.0(3)T or higher. It is recommended to test it on less critical routers first. + +=head1 INSTALLATION + +To install this probe copy ciscoRttMonMIB.pm to ($SMOKEPINGINSTALLDIR)/lib and CiscoRTTMonTcpConnect.pm to ($SMOKEPINGINSTALLDIR)/lib/probes. V0.97 or higher of Simon Leinen's SNMP_Session.pm is required. + +The router(s) must be configured to allow read/write SNMP access. Sufficient is: + + snmp-server community RTTCommunity RW + +If you want to be a bit more restrictive with SNMP write access to the router, then consider configuring something like this + + access-list 2 permit 10.37.3.5 + snmp-server view RttMon ciscoRttMonMIB included + snmp-server community RTTCommunity view RttMon RW 2 + +The above configuration grants SNMP read-write only to 10.37.3.5 (the smokeping host) and only to the ciscoRttMon MIB tree. The probe does not need access to SNMP variables outside the RttMon tree. + +=head1 BUGS + +The probe establishes unnecessary connections, i.e. more than configured in the "pings" variable, because the RTTMon MIB only allows to set a total time for all connections in one measurement run (one "life"). Currently the probe sets the life duration to "pings"*2+3 seconds (2 secs is the timeout value hardcoded into this probe). + +=head1 SEE ALSO + +http://people.ee.ethz.ch/~oetiker/webtools/smokeping/ +http://www.switch.ch/misc/leinen/snmp/perl/ + +The best source for background info on SAA is Cisco's documentation on http://www.cisco.com and the CISCO-RTTMON-MIB documentation, which is available at: +ftp://ftp.cisco.com/pub/mibs/v2/CISCO-RTTMON-MIB.my + + + +=head1 AUTHOR + +Joerg.Kummer at Roche.com + +=cut + +use strict; +use base qw(probes::basefork); +use Symbol; +use Carp; +use BER; +use SNMP_Session; +use SNMP_util "0.97"; +use ciscoRttMonMIB "0.2"; + +my $pingtimeout =2; + +sub new($$$) +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ( $ENV{SERVER_SOFTWARE} ) { + $self->{pingfactor} = 1000; + }; + return $self; +} + +sub ProbeDesc($){ + my $self = shift; + my $bytes = $self->{properties}{packetsize} || 56; + return "CiscoRTTMonTcpConnect ($bytes Bytes)"; +} + +sub pingone ($$) { + my $self = shift; + my $target = shift; + + croak ("please define 'ioshost' under the PROBE_CONF section of your target\n") + unless defined $target->{vars}{ioshost} ; + + my $pings = $self->pings($target) || 20; + my $tos = $target->{vars}{tos} || 0; + my $port = $target->{vars}{port} || 80; + + # use the proces ID as as row number to make this poll distinct on the router; + my $row=$$; + + if (defined + StartRttMibEcho($target->{vars}{ioshost}.":::::2", $target->{addr}, $port, + $pings, $target->{vars}{iosint}, $tos, $row)) + { + # wait for the series to finish + sleep ($pings*$pingtimeout+5); + if (my @times=FillTimesFromHistoryTable($target->{vars}{ioshost}.":::::2", $pings, $row)){ + DestroyData ($target->{vars}{ioshost}.":::::2", $row); + return @times; + } + else { + return(); + } + } + else { + return (); + } +} + +sub StartRttMibEcho ($$$$$$){ + my ($host, $target, $port, $pings, $sourceip, $tos, $row) = @_; + + # resolve the target name and encode its IP address + $_=$target; + if (!/^([0-9]|\.)+/) { + (my $name, my $aliases, my $addrtype, my $length, my @addrs) = gethostbyname ($target); + $target=join('.',(unpack("C4",$addrs[0]))); + } + my @octets=split(/\./,$target); + my $encoded_target= pack ("CCCC", @octets); + + # resolve the source name and encode its IP address + my $encoded_source = undef; + if (defined $sourceip) { + $_=$sourceip; + if (!/^([0-9]|\.)+/) { + (my $name, my $aliases, my $addrtype, my $length, my @addrs) = gethostbyname ($sourceip); + $sourceip=join('.',(unpack("C4",$addrs[0]))); + } + my @octets=split(/\./,$sourceip); + $encoded_source= pack ("CCCC", @octets); + } + + ############################################################# + # rttMonCtrlAdminStatus - 1:active 2:notInService 3:notReady 4:createAndGo 5:createAndWait 6:destroy + #delete data from former measurements + #return undef unless defined + # &snmpset($host, "rttMonCtrlAdminStatus.$row",'integer', 6); + + ############################################################# + # Check RTTMon version and supported protocols + $SNMP_Session::suppress_warnings = 10; # be silent + (my $version)=&snmpget ($host, "rttMonApplVersion"); + if (! defined $version ) { + Smokeping::do_log ("$host doesn't support or allow RTTMon !\n"); + return undef; + } + Smokeping::do_log ("$host supports $version\n"); + $SNMP_Session::suppress_warnings = 0; # report errors + + # echo(1), pathEcho(2), fileIO(3), script(4), udpEcho(5), tcpConnect(6), http(7), + # dns(8), jitter(9), dlsw(10), dhcp(11), ftp(12) + + my $tcpConnSupported=0==1; + snmpmaptable ($host, + sub () { + my ($proto, $supported) = @_; + # 1 is true , 2 is false + $tcpConnSupported=0==0 if ($proto==6 && $supported==1); + }, + "rttMonApplSupportedRttTypesValid"); + + if (! $tcpConnSupported) { + Smokeping::do_log ("$host doesn't support TCP connection time measurements !\n"); + return undef; + } + + + ############################################################# + #setup the new data row + + my @params=(); + push @params, + "rttMonCtrlAdminStatus.$row", 'integer', 5, + "rttMonCtrlAdminRttType.$row", 'integer', 6, + "rttMonEchoAdminProtocol.$row", 'integer', 24, + "rttMonEchoAdminTargetAddress.$row", 'octetstring', $encoded_target, + "rttMonEchoAdminTargetPort.$row", 'integer', $port, + "rttMonCtrlAdminTimeout.$row", 'integer', $pingtimeout*1000, + "rttMonCtrlAdminFrequency.$row", 'integer', $pingtimeout, + "rttMonEchoAdminControlEnable.$row", 'integer', 2, + "rttMonEchoAdminTOS.$row", 'integer', $tos, + "rttMonCtrlAdminNvgen.$row", 'integer', 2, + "rttMonHistoryAdminNumBuckets.$row", 'integer', $pings, + "rttMonHistoryAdminNumLives.$row", 'integer', 1, + "rttMonHistoryAdminFilter.$row", 'integer', 2, + "rttMonScheduleAdminRttStartTime.$row", 'timeticks', 1, + "rttMonScheduleAdminRttLife.$row", 'integer', $pings*$pingtimeout+3, + "rttMonScheduleAdminConceptRowAgeout.$row",'integer', 60; + + # the router (or this script) doesn't check whether the IP address is one of + # the router's IP address, i.e. the router might send packets, but never + # gets replies.. + if (defined $sourceip) { + push @params, "rttMonEchoAdminSourceAddress.$row", 'octetstring', $encoded_source; + } + + return undef unless defined + &snmpset($host, @params); + + ############################################################# + # and go ! + return undef unless defined + &snmpset($host, "rttMonCtrlAdminStatus.$row",'integer',1); + + return 1; +} + + +# RttResponseSense values +# 1:ok 2:disconnected 3:overThreshold 4:timeout 5:busy 6:notConnected 7:dropped 8:sequenceError +# 9:verifyError 10:applicationSpecific 11:dnsServerTimeout 12:tcpConnectTimeout 13:httpTransactionTimeout +#14:dnsQueryError 15:httpError 16:error + +sub FillTimesFromHistoryTable($$$$) { + my ($host, $pings, $row) = @_; + my @times; + + # snmpmaptable walks two columns of rttMonHistoryCollectionTable + # - "rttMonHistoryCollectionCompletionTime.$row", + # - "rttMonHistoryCollectionSense.$row" + # The code in the sub() argument is executed for each index value snmptable walks + snmpmaptable ($host, + sub () { + my ($index, $rtt, $status) = @_; + push @times, (sprintf ("%.10e", $rtt/1000)) + if ($status==1); + }, + "rttMonHistoryCollectionCompletionTime.$row", + "rttMonHistoryCollectionSense.$row"); + + return sort { $a <=> $b } @times; +} + +sub DestroyData ($$) { + my ($host, $row) = @_; + + &snmpset($host, "rttMonCtrlOperState.$row", 'integer', 3); + &snmpset($host, "rttMonCtrlAdminStatus.$row", 'integer', 2); + #delete any old config + &snmpset($host, "rttMonCtrlAdminStatus.$row", 'integer', 6); +} + +1; + diff --git a/lib/probes/Curl.pm b/lib/probes/Curl.pm new file mode 100644 index 0000000..9dc4d31 --- /dev/null +++ b/lib/probes/Curl.pm @@ -0,0 +1,236 @@ +package probes::Curl; + +my $DEFAULTBIN = "/usr/bin/curl"; + +=head1 NAME + +probes::Curl - a curl(1) probe for SmokePing + +=head1 OVERVIEW + +Fetches an HTTP or HTTPS URL using curl(1). + +=head1 SYNOPSYS + + *** Probes *** + + Curl + + binary = /usr/bin/curl # default value + + *** Targets *** + + probe = Curl + forks = 10 + + menu = Top + title = Top Menu + remark = Top Menu Remark + + + PROBE_CONF + + + First + menu = First + title = First Target + host = some.host + + # PROBE_CONF can be overridden here + ++ PROBE_CONF + agent = "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.2.1) Gecko/20021130" + url = https://some.host/some/where + +=head1 DESCRIPTION + +Supported probe-specific variables: + +=over + +=item binary + +The location of your curl binary. + +=item forks + +The number of concurrent processes to be run. See probes::basefork(3pm) +for details. + +=item url + +The URL to fetch. Can be any one that curl supports. + +=back + +Supported target-level probe variables +(see curl(1) for details of the options): + +=over + +=item agent + +The "-A" curl(1) option. This is a full HTTP User-Agent header including +the words "User-Agent:". It should be enclosed in quotes if it contains +shell metacharacters + +=item ssl2 + +The "-2" curl(1) option. Force SSL2. + +=item timeout + +The "-m" curl(1) option. Maximum timeout in seconds. + +=item interface + +The "--interface" curl(1) option. Bind to a specific interface, IP address or +host name. + +=back + +=head1 AUTHORS + +Gerald Combs E<lt>gerald [AT] ethereal.comE<gt> +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 SEE ALSO + +curl(1), probes::Curl(3pm) etc., http://curl.haxx.se/ + +=cut + +use strict; +use base qw(probes::basefork); +use Carp; +# +# derived class will mess with this through the 'features' method below +my $featurehash = { + agent => "-A", + timeout => "-m", + interface => "--interface", +}; + +sub features { + my $self = shift; + my $newval = shift; + $featurehash = $newval if defined $newval; + return $featurehash; +} + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + $self->_init if $self->can('_init'); + + unless (defined $self->{properties}{binary}) { + $self->{properties}{binary} = $DEFAULTBIN; + } + croak "ERROR: Curl 'binary' $self->{properties}{binary} does not point to an executable" + unless -f $self->{properties}{binary} and -x $self->{properties}{binary}; + + $self->test_usage; + + return $self; +} + +# warn about unsupported features +sub test_usage { + my $self = shift; + my $bin = $self->{properties}{binary}; + my @unsupported; + + my $arghashref = $self->features; + my %arghash = %$arghashref; + + for my $feature (keys %arghash) { + if (`$bin $arghash{$feature} 1 127.0.0.1 2>&1` =~ /invalid option|usage/i) { + push @unsupported, $feature; + $self->do_log("Note: your curl doesn't support the $feature feature (option $arghash{$feature}), disabling it"); + } + } + map { delete $arghashref->{$_} } @unsupported; + + return; +} + +sub ProbeDesc($) { + return "HTTP, HTTPS, and FTP URLs using curl(1)"; +} + +# This can be overridden to tag the port number to the address +# in derived classes (namely Curl) +sub make_host { + my $self = shift; + my $target = shift; + return $target->{addr}; +} + + +# other than host, count and protocol-specific args come from here +sub make_args { + my $self = shift; + my $target = shift; + my @args; + my %arghash = %{$self->features}; + + for (keys %arghash) { + my $val = $target->{vars}{$_}; + $val = $self->{properties}{$_} unless defined $val; + push @args, ($arghash{$_}, $val) if defined $val; + } + return @args; +} + +# This is what derived classes will override +sub proto_args { + my $self = shift; + my $target = shift; + # XXX - It would be neat if curl had a "time_transfer". For now, + # we take the total time minus the DNS lookup time. + my @args = ("-o /dev/null", "-w 'Time: %{time_total} DNS time: %{time_namelookup}\\n'"); + my $ssl2 = $target->{vars}{ssl2}; + push (@args, "-2") if defined($ssl2); + return(@args); + +} + +sub make_commandline { + my $self = shift; + my $target = shift; + my $count = shift; + + my @args = $self->make_args($target); + my $url = $target->{vars}{url}; + $url = "" unless defined $url; + push @args, $self->proto_args($target); + + return ($self->{properties}{binary}, @args, $url); +} + +sub pingone { + my $self = shift; + my $t = shift; + + my @cmd = $self->make_commandline($t); + + my $cmd = join(" ", @cmd); + + $self->do_debug("executing cmd $cmd"); + + my @times; + my $count = $self->pings($t); + + for (my $i = 0 ; $i < $count; $i++) { + open(P, "$cmd 2>&1 |") or croak("fork: $!"); + + # what should we do with error messages? + while (<P>) { + /^Time: (\d+\.\d+) DNS time: (\d+\.\d+)/ and push @times, $1 - $2; + } + close P; + } + + # carp("Got @times") if $self->debug; + return sort { $a <=> $b } @times; +} + +1; diff --git a/lib/probes/DNS.pm b/lib/probes/DNS.pm new file mode 100644 index 0000000..877ca97 --- /dev/null +++ b/lib/probes/DNS.pm @@ -0,0 +1,147 @@ +package probes::DNS; + +=head1 NAME + +probes::DNS - Name Service Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + DNS + binary = /usr/bin/dig + + *** Targets *** + probe = DNS + forks = 10 + + + First + menu = First + title = First Target + # .... + + ++ PROBE_CONF + lookup=www.mozilla.org + +=head1 DESCRIPTION + +Integrates dig as a probe into smokeping. The variable B<binary> must +point to your copy of the dig program. If it is not installed on +your system yet, you should install bind-utils >= 9.0.0. + +The Probe asks the given host n-times for it's name. Where n is +the amount specified in the config File. + +Supported probe-specific variables: + +=over + +=item binary + +The location of your dig binary. + +=item forks + +The number of concurrent processes to be run. See probes::basefork(3pm) +for details. + +=back + +Supported target-level probe variables: + +=over + +=item lookup + +Name of the host to look up in the dns. + +=back + + +=head1 AUTHOR + +Igor Petrovski E<lt>pigor@myrealbox.comE<gt>, +Carl Elkins E<lt>carl@celkins.org.ukE<gt>, +Andre Stolze E<lt>stolze@uni-muenster.deE<gt>, +Niko Tyni E<lt>ntyni@iki.fiE<gt>, +Chris Poetzel<lt>cpoetzel@anl.gov<gt> + + +=cut + +use strict; +use base qw(probes::basefork); +use IPC::Open3; +use Symbol; +use Carp; + +my $dig_re=qr/query time:\s+([0-9.]+)\smsec.*/i; + +sub new($$$) +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ( $ENV{SERVER_SOFTWARE} ) { + + croak "ERROR: DNS 'binary' not defined in FPing probe definition" + unless defined $self->{properties}{binary}; + + croak "ERROR: DNS 'binary' does not point to an executable" + unless -f $self->{properties}{binary} and -x $self->{properties}{binary}; + my $call = "$self->{properties}{binary} localhost"; + my $return = `$call 2>&1`; + if ($return =~ m/$dig_re/s){ + $self->{pingfactor} = 1000; + print "### parsing dig output...OK\n"; + } else { + croak "ERROR: output of '$call' does not match $dig_re\n"; + } + }; + + return $self; +} + +sub ProbeDesc($){ + my $self = shift; + return "DNS requests"; +} + +sub pingone ($){ + my $self = shift; + my $target = shift; + + my $inh = gensym; + my $outh = gensym; + my $errh = gensym; + + my $host = $target->{addr}; + my $lookuphost = $target->{vars}{lookup}; + $lookuphost = $target->{addr} unless defined $lookuphost; + + #my $host = $target->{addr}; + my $query = "$self->{properties}{binary} \@$host $lookuphost"; + my @times; + + $self->do_debug("query=$query\n"); + for (my $run = 0; $run < $self->pings($target); $run++) { + my $pid = open3($inh,$outh,$errh, $query); + while (<$outh>) { + if (/$dig_re/i) { + push @times, $1; + last; + } + } + waitpid $pid,0; + close $errh; + close $inh; + close $outh; + } + @times = map {sprintf "%.10e", $_ / $self->{pingfactor}} sort {$a <=> $b} grep {$_ ne "-"} @times; + +# $self->do_debug("time=@times\n"); + return @times; +} + +1; diff --git a/lib/probes/EchoPing.pm b/lib/probes/EchoPing.pm new file mode 100644 index 0000000..d7558fa --- /dev/null +++ b/lib/probes/EchoPing.pm @@ -0,0 +1,303 @@ +package probes::EchoPing; + +my $DEFAULTBIN = "/usr/bin/echoping"; + +=head1 NAME + +probes::EchoPing - an echoping(1) probe for SmokePing + +=head1 OVERVIEW + +Measures TCP or UDP echo (port 7) roundtrip times for SmokePing. Can also be +used as a base class for other echoping(1) probes. + +=head1 SYNOPSYS + + *** Probes *** + + EchoPing + + binary = /usr/bin/echoping # default value + + *** Targets *** + + probe = EchoPing + forks = 10 + + menu = Top + title = Top Menu + remark = Top Menu Remark + + + PROBE_CONF + + # none of these are mandatory + timeout = 1 + waittime = 1 + udp = no + size = 510 + tos = 0xa0 + priority = 6 + + + First + menu = First + title = First Target + host = router.example.com + + # PROBE_CONF can be overridden here + ++ PROBE_CONF + size = 300 + +=head1 DESCRIPTION + +Supported probe-specific variables: + +=over + +=item binary + +The location of your echoping binary. + +=item forks + +The number of concurrent processes to be run. See probes::basefork(3pm) +for details. + +=back + +Supported target-level probe variables +(see echoping(1) for details of the options): + +=over + +=item timeout + +The "-t" echoping(1) option. + +=item waittime + +The "-w" echoping(1) option. + +=item size + +The "-s" echoping(1) option. + +=item udp + +The "-u" echoping(1) option. Values other than '0' and 'no' enable UDP. + +=item fill + +The "-f" echoping(1) option. + +=item priority + +The "-p" echoping(1) option. + +=item tos + +The "-P" echoping(1) option. + +=item ipversion + +The IP protocol used. Possible values are "4" and "6". +Passed to echoping(1) as the "-4" or "-6" options. + +=item extraopts + +Any extra options specified here will be passed unmodified to echoping(1). + +=back + +=head1 BUGS + +Should we test the availability of the service at startup? After that it's +too late to complain. + +The location of the echoping binary should probably be a global variable +instead of a probe-specific one. As things are, every EchoPing -derived probe +has to declare it if the default (/usr/bin/echoping) isn't correct. + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 SEE ALSO + +echoping(1), probes::EchoPingHttp(3pm) etc., http://echoping.sourceforge.net/ + +=cut + +use strict; +use base qw(probes::basefork); +use Carp; +# +# derived class will mess with this through the 'features' method below +my $featurehash = { + waittime => "-w", + timeout => "-t", + size => "-s", + tos => "-P", + priority => "-p", + fill => "-f", +}; + +sub features { + my $self = shift; + my $newval = shift; + $featurehash = $newval if defined $newval; + return $featurehash; +} + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + $self->_init if $self->can('_init'); + + unless (defined $self->{properties}{binary}) { + $self->{properties}{binary} = $DEFAULTBIN; + } + croak "ERROR: EchoPing 'binary' $self->{properties}{binary} does not point to an executable" + unless -f $self->{properties}{binary} and -x $self->{properties}{binary}; + + $self->test_usage; + + return $self; +} + +# warn about unsupported features +sub test_usage { + my $self = shift; + my $bin = $self->{properties}{binary}; + my @unsupported; + + my $arghashref = $self->features; + my %arghash = %$arghashref; + + for my $feature (keys %arghash) { + if (`$bin $arghash{$feature} 1 127.0.0.1 2>&1` =~ /invalid option|usage/i) { + push @unsupported, $feature; + $self->do_log("Note: your echoping doesn't support the $feature feature (option $arghash{$feature}), disabling it"); + } + } + map { delete $arghashref->{$_} } @unsupported; + + return; +} + +sub ProbeDesc($) { + return "TCP or UDP Echo pings using echoping(1)"; +} + +# This can be overridden to tag the port number to the address +# in derived classes (namely EchoPingHttp) +sub make_host { + my $self = shift; + my $target = shift; + return $target->{addr}; +} + + +# other than host, count and protocol-specific args come from here +sub make_args { + my $self = shift; + my $target = shift; + my @args; + my %arghash = %{$self->features}; + + for (keys %arghash) { + my $val = $target->{vars}{$_}; + $val = $self->{properties}{$_} unless defined $val; + push @args, ($arghash{$_}, $val) if defined $val; + } + push @args, $self->ipversion_arg($target); + push @args, $self->{properties}{extraopts} if exists $self->{properties}{extraopts}; + push @args, $target->{vars}{extraopts} if exists $target->{vars}{extraopts}; + + return @args; +} + +# this is separated to make it possible to test the service +# at startup, although we don't do it at the moment. +sub count_args { + my $self = shift; + my $count = shift; + + $count = $self->pings() unless defined $count; + return ("-n", $count); +} + +# This is what derived classes will override +sub proto_args { + my $self = shift; + return $self->udp_arg(@_); +} + +# UDP is defined only for echo and discard +sub udp_arg { + my $self = shift; + my $target = shift; + my @args; + + my $udp = $target->{vars}{udp}; + $udp = $self->{properties}{udp} unless defined $udp; + push @args, "-u" if (defined $udp and $udp ne "no" and $udp ne "0"); + + return @args; +} + +sub ipversion_arg { + my $self = shift; + my $target = shift; + my $vers = $target->{vars}{ipversion}; + $vers = $self->{properties}{ipversion} unless defined $vers; + if (defined $vers and $vers =~ /^([46])$/) { + return ("-" . $1); + } else { + $self->do_log("Invalid `ipversion' value: $vers") if defined $vers; + return (); + } +} + +sub make_commandline { + my $self = shift; + my $target = shift; + my $count = shift; + + $count |= $self->pings($target); + + my @args = $self->make_args($target); + my $host = $self->make_host($target); + push @args, $self->proto_args($target); + push @args, $self->count_args($count); + + return ($self->{properties}{binary}, @args, $host); +} + +sub pingone { + my $self = shift; + my $t = shift; + + my @cmd = $self->make_commandline($t); + + my $cmd = join(" ", @cmd); + + $self->do_debug("executing cmd $cmd"); + + my @times; + + open(P, "$cmd 2>&1 |") or carp("fork: $!"); + + # what should we do with error messages? + my $echoret; + while (<P>) { + $echoret .= $_; + /^Elapsed time: (\d+\.\d+) seconds/ and push @times, $1; + } + close P; + carp "WARNING: $cmd was not happy: $echoret\n" if $?; + # carp("Got @times") if $self->debug; + return sort { $a <=> $b } @times; +} + +1; diff --git a/lib/probes/EchoPingChargen.pm b/lib/probes/EchoPingChargen.pm new file mode 100644 index 0000000..712953a --- /dev/null +++ b/lib/probes/EchoPingChargen.pm @@ -0,0 +1,60 @@ +package probes::EchoPingChargen; + +=head1 NAME + +probes::EchoPingChargen - an echoping(1) probe for SmokePing + +=head1 OVERVIEW + +Measures TCP chargen (port 19) roundtrip times for SmokePing. + +=head1 SYNOPSYS + + *** Probes *** + + EchoPingChargen + + binary = /usr/bin/echoping + + *** Targets *** + + probe = EchoPingChargen + +=head1 DESCRIPTION + +Supported probe- and target-specific variables: see probes::EchoPing(3pm) + +Note: the I<udp> variable is not supported. + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 SEE ALSO + +probes::EchoPing(3pm) + +=cut + + +use strict; +use base qw(probes::EchoPing); +use Carp; + +sub proto_args { + return ("-c"); +} + +sub test_usage { + my $self = shift; + my $bin = $self->{properties}{binary}; + croak("Your echoping binary doesn't support CHARGEN") + if `$bin -c 2>&1 127.0.0.1` =~ /(usage|not compiled|invalid option)/i; + $self->SUPER::test_usage; + return; +} + +sub ProbeDesc($) { + return "TCP Chargen pings using echoping(1)"; +} + +1; diff --git a/lib/probes/EchoPingDiscard.pm b/lib/probes/EchoPingDiscard.pm new file mode 100644 index 0000000..e961090 --- /dev/null +++ b/lib/probes/EchoPingDiscard.pm @@ -0,0 +1,61 @@ +package probes::EchoPingDiscard; + +=head1 NAME + +probes::EchoPingDiscard - an echoping(1) probe for SmokePing + +=head1 OVERVIEW + +Measures TCP or UDP discard (port 9) roundtrip times for SmokePing. + +=head1 SYNOPSYS + + *** Probes *** + + EchoPingDiscard + + binary = /usr/bin/echoping + + *** Targets *** + + probe = EchoPingDiscard + +=head1 DESCRIPTION + +Supported probe- and target-specific variables: see probes::EchoPing(3pm) + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 SEE ALSO + +probes::EchoPing(3pm) + +=cut + +use strict; +use base qw(probes::EchoPing); +use Carp; + +sub proto_args { + my $self = shift; + my $target = shift; + my @args = $self->udp_arg; + return ("-d", @args); +} + +sub test_usage { + my $self = shift; + my $bin = $self->{properties}{binary}; + croak("Your echoping binary doesn't support DISCARD") + if `$bin -d 127.0.0.1 2>&1` =~ /(not compiled|invalid option|usage)/i; + $self->SUPER::test_usage; + return; +} + +sub ProbeDesc($) { + return "TCP or UDP Discard pings using echoping(1)"; +} + + +1; diff --git a/lib/probes/EchoPingHttp.pm b/lib/probes/EchoPingHttp.pm new file mode 100644 index 0000000..4e261b8 --- /dev/null +++ b/lib/probes/EchoPingHttp.pm @@ -0,0 +1,164 @@ +package probes::EchoPingHttp; + +=head1 NAME + +probes::EchoPingHttp - an echoping(1) probe for SmokePing + +=head1 OVERVIEW + +Measures HTTP roundtrip times (web servers and caches) for SmokePing. + +=head1 SYNOPSYS + + *** Probes *** + + EchoPingHttp + + binary = /usr/bin/echoping # mandatory + + + *** Targets *** + + probe = EchoPingHttp + + + PROBE_CONF + url = / + ignore_cache = yes + revalidate_data = no + port = 80 # default value anyway + timeout = 50 # default is 10s + +=head1 DESCRIPTION + +Supported probe-specific variables: those specified in EchoPing(3pm) +documentation. + +Supported target-specific variables: + +=over + +=item those specified in EchoPing(3pm) documentation + +except I<fill>, I<size> and I<udp>. + +=item url + +The URL to be requested from the web server or cache. Can be either relative +(/...) for web servers or absolute (http://...) for caches. + +=item port + +The TCP port to use. The default is 80. + +=item ignore_cache + +The echoping(1) "-A" option: force the proxy to ignore the cache. +Enabled if the value is anything other than 'no' or '0'. + +=item revalidate_data + +The echoping(1) "-a" option: force the proxy to revalidate data with original +server. Enabled if the value is anything other than 'no' or '0'. + +=item timeout + +The echoping(1) "-t" option: Number of seconds to wait a reply before giving up. For TCP, +this is the maximum number of seconds for the whole connection +(setup and data exchange). + +=back + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 SEE ALSO + +EchoPing(3pm), EchoPingHttps(3pm) + +=cut + +use strict; +use base qw(probes::EchoPing); +use Carp; + +sub _init { + my $self = shift; + # HTTP doesn't fit with filling or size + my $arghashref = $self->features; + delete $arghashref->{size}; + delete $arghashref->{fill}; +} + +# tag the port number after the hostname +sub make_host { + my $self = shift; + my $target = shift; + + my $host = $self->SUPER::make_host($target); + my $port = $target->{vars}{port}; + $port = $self->{properties}{port} unless defined $port; + + $host .= ":$port" if defined $port; + return $host; +} + +sub proto_args { + my $self = shift; + my $target = shift; + my $url = $target->{vars}{url}; + $url = $self->{properties}{url} unless defined $url; + $url = "/" unless defined $url; + + my @args = ("-h", $url); + + # -t : timeout + my $timeout = $target->{vars}{timeout}; + $timeout = $self->{properties}{timeout} + unless defined $timeout; + push @args, "-t $timeout" if $timeout; + + # -A : ignore cache + my $ignore = $target->{vars}{ignore_cache}; + $ignore = $self->{properties}{ignore_cache} + unless defined $ignore; + $ignore = 1 + if (defined $ignore and $ignore ne "no" + and $ignore ne "0"); + push @args, "-A" if $ignore and not exists $self->{_disabled}{A}; + + # -a : force cache to revalidate the data + my $revalidate = $target->{vars}{revalidate_data}; + $revalidate = $self->{properties}{revalidate_data} + unless defined $revalidate; + $revalidate= 1 if (defined $revalidate and $revalidate ne "no" + and $revalidate ne "0"); + push @args, "-a" if $revalidate and not exists $self->{_disabled}{a}; + + return @args; +} + +sub test_usage { + my $self = shift; + my $bin = $self->{properties}{binary}; + croak("Your echoping binary doesn't support HTTP") + if `$bin -h/ 127.0.0.1 2>&1` =~ /(invalid option|not compiled|usage)/i; + if (`$bin -a -h/ 127.0.0.1 2>&1` =~ /(invalid option|not compiled|usage)/i) { + carp("Note: your echoping binary doesn't support revalidating (-a), disabling it"); + $self->{_disabled}{a} = undef; + } + + if (`$bin -A -h/ 127.0.0.1 2>&1` =~ /(invalid option|not compiled|usage)/i) { + carp("Note: your echoping binary doesn't support ignoring cache (-A), disabling it"); + $self->{_disabled}{A} = undef; + } + + $self->SUPER::test_usage; + return; +} + +sub ProbeDesc($) { + return "HTTP pings using echoping(1)"; +} + + +1; diff --git a/lib/probes/EchoPingHttps.pm b/lib/probes/EchoPingHttps.pm new file mode 100644 index 0000000..84f8b85 --- /dev/null +++ b/lib/probes/EchoPingHttps.pm @@ -0,0 +1,70 @@ +package probes::EchoPingHttps; + +=head1 NAME + +probes::EchoPingHttps - an echoping(1) probe for SmokePing + +=head1 OVERVIEW + +Measures HTTPS (HTTP over SSL) roundtrip times (web servers and caches) for +SmokePing. + +=head1 SYNOPSYS + + *** Probes *** + + EchoPingHttps + + binary = /usr/bin/echoping # mandatory + + *** Targets *** + + probe = EchoPingHttps + + + PROBE_CONF + url = / + ignore-cache = yes + force-revalidate = no + port = 443 # default value anyway + +=head1 DESCRIPTION + +As EchoPingHttp(3pm), but SSL-enabled. + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 SEE ALSO + +EchoPingHttp(3pm) + +=cut + +use strict; +use base qw(probes::EchoPingHttp); +use Carp; + +sub proto_args { + my $self = shift; + my $target = shift; + my @args = $self->SUPER::proto_args($target); + return ("-C", @args); +} + +sub test_usage { + my $self = shift; + + my $bin = $self->{properties}{binary}; + my $response = `$bin -C -h/ 127.0.0.1 2>&1`; + croak("Your echoping binary doesn't support SSL") + if ($response =~ /(not compiled|invalid option|usage)/i); + $self->SUPER::test_usage; + return; +} + +sub ProbeDesc($) { + return "HTTPS pings using echoping(1)"; +} + + +1; diff --git a/lib/probes/EchoPingIcp.pm b/lib/probes/EchoPingIcp.pm new file mode 100644 index 0000000..13ba896 --- /dev/null +++ b/lib/probes/EchoPingIcp.pm @@ -0,0 +1,94 @@ +package probes::EchoPingIcp; + +=head1 NAME + +probes::EchoPingIcp - an echoping(1) probe for SmokePing + +=head1 OVERVIEW + +Measures ICP (Internet Cache Protocol, spoken by web caches) +roundtrip times for SmokePing. + +=head1 SYNOPSYS + + *** Probes *** + + EchoPingIcp + + binary = /usr/bin/echoping # mandatory + + *** Targets *** + + probe = EchoPingHttp + + + PROBE_CONF + # this can be overridden in the targets' PROBE_CONF sections + url = / + + +=head1 DESCRIPTION + +Supported probe-specific variables: those specified in EchoPing(3pm) +documentation. + +Supported target-specific variables: + +=over + +=item those specified in EchoPing(3pm) documentation + +except I<fill>, I<size> and I<udp>. + +=item url + +The URL to be requested from the web cache. + +=back + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 SEE ALSO + +EchoPing(3pm), EchoPingHttp(3pm) + +=cut + +use strict; +use base qw(probes::EchoPing); +use Carp; + +sub _init { + my $self = shift; + # Icp doesn't fit with filling or size + my $arghashref = $self->features; + delete $arghashref->{size}; + delete $arghashref->{fill}; +} + +sub proto_args { + my $self = shift; + my $target = shift; + my $url = $target->{vars}{url}; + $url = $self->{properties}{url} unless defined $url; + $url = "/" unless defined $url; + + my @args = ("-i", $url); + + return @args; +} + +sub test_usage { + my $self = shift; + my $bin = $self->{properties}{binary}; + croak("Your echoping binary doesn't support ICP") + if `$bin -i/ 127.0.0.1 2>&1` =~ /not compiled|usage/i; + $self->SUPER::test_usage; + return; +} + +sub ProbeDesc($) { + return "ICP pings using echoping(1)"; +} + +1; diff --git a/lib/probes/EchoPingSmtp.pm b/lib/probes/EchoPingSmtp.pm new file mode 100644 index 0000000..ef6eba0 --- /dev/null +++ b/lib/probes/EchoPingSmtp.pm @@ -0,0 +1,68 @@ +package probes::EchoPingSmtp; + +=head1 NAME + +probes::EchoPingSmtp - an echoping(1) probe for SmokePing + +=head1 OVERVIEW + +Measures SMTP roundtrip times (mail servers) for SmokePing. + +=head1 SYNOPSYS + + *** Probes *** + + EchoPingSmtp + + binary = /usr/bin/echoping # mandatory + + *** Targets *** + probe = EchoPingSmtp + +=head1 DESCRIPTION + +Supported probe-specific variables: those specified in EchoPing(3pm) +documentation. + +Supported target-specific variables: those specified in +EchoPing(3pm) documentation except I<fill>, I<size> and I<udp>. + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 SEE ALSO + +EchoPing(3pm) + +=cut + +use strict; +use base qw(probes::EchoPing); +use Carp; + +sub _init { + my $self = shift; + # SMTP doesn't fit with filling or size + my $arghashref = $self->features; + delete $arghashref->{size}; + delete $arghashref->{fill}; +} + +sub proto_args { + return ("-S"); +} + +sub test_usage { + my $self = shift; + my $bin = $self->{properties}{binary}; + croak("Your echoping binary doesn't support SMTP") + if `$bin -S 127.0.0.1 2>&1` =~ /(not compiled|invalid option|usage)/i; + $self->SUPER::test_usage; + return; +} + +sub ProbeDesc($) { + return "SMTP pings using echoping(1)"; +} + +1; diff --git a/lib/probes/FPing.pm b/lib/probes/FPing.pm new file mode 100644 index 0000000..9e146f6 --- /dev/null +++ b/lib/probes/FPing.pm @@ -0,0 +1,117 @@ +package probes::FPing; + +=head1 NAME + +probes::FPing - FPing Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + FPing + binary = /usr/sepp/bin/fping + packetsize = 1024 + +=head1 DESCRIPTION + +Integrates FPing as a probe into smokeping. The variable B<binary> must +point to your copy of the FPing program. If it is not installed on +your system yet, you can get it from http://www.fping.com/. + +The (optional) packetsize option lets you configure the packetsize for the pings sent. +The FPing manpage has the following to say on this topic: + +Number of bytes of ping data to send. The minimum size (normally 12) allows +room for the data that fping needs to do its work (sequence number, +timestamp). The reported received data size includes the IP header +(normally 20 bytes) and ICMP header (8 bytes), so the minimum total size is +40 bytes. Default is 56, as in ping. Maximum is the theoretical maximum IP +datagram size (64K), though most systems limit this to a smaller, +system-dependent number. + +=head1 AUTHOR + +Tobias Oetiker <tobi@oetiker.ch> + +=cut + +use strict; +use base qw(probes::base); +use IPC::Open3; +use Symbol; +use Carp; + +sub new($$$) +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ( $ENV{SERVER_SOFTWARE} ) { + croak "ERROR: FPing packetsize must be between 12 and 64000" + if $self->{properties}{packetsize} and + ( $self->{properties}{packetsize} < 12 or $self->{properties}{packetsize} > 64000 ); + + croak "ERROR: FPing 'binary' not defined in FPing probe definition" + unless defined $self->{properties}{binary}; + + croak "ERROR: FPing 'binary' does not point to an executable" + unless -f $self->{properties}{binary} and -x $self->{properties}{binary}; + + my $return = `$self->{properties}{binary} -C 1 localhost 2>&1`; + croak "ERROR: FPing must be installed setuid root or it will not work\n" + if $return =~ m/only.+root/; + + if ($return =~ m/bytes, ([0-9.]+)\sms\s+.*\n.*\n.*:\s+([0-9.]+)/ and $1 > 0){ + $self->{pingfactor} = 1000 * $2/$1; + print "### fping seems to report in ", $1/$2, " milliseconds\n"; + } else { + $self->{pingfactor} = 1000; # Gives us a good-guess default + print "### assuming you are using an fping copy reporting in milliseconds\n"; + } + }; + + return $self; +} + +sub ProbeDesc($){ + my $self = shift; + my $bytes = $self->{properties}{packetsize} || 56; + return "ICMP Echo Pings ($bytes Bytes)"; +} + +sub ping ($){ + my $self = shift; + # do NOT call superclass ... the ping method MUST be overwriten + my %upd; + my $inh = gensym; + my $outh = gensym; + my $errh = gensym; + # pinging nothing is pointless + return unless @{$self->addresses}; + my @bytes = () ; + push @bytes, "-b$self->{properties}{packetsize}" if $self->{properties}{packetsize}; + my @cmd = ( + $self->{properties}{binary}, @bytes, + '-C', $self->pings, '-q','-B1','-i10','-r1', + @{$self->addresses}); + $self->do_debug("Executing @cmd"); + my $pid = open3($inh,$outh,$errh, @cmd); + $self->{rtts}={}; + while (<$errh>){ + chomp; + next unless /^\S+\s+:\s+[\d\.]/; #filter out error messages from fping + my @times = split /\s+/; + my $ip = shift @times; + next unless ':' eq shift @times; #drop the colon + + @times = map {sprintf "%.10e", $_ / $self->{pingfactor}} sort {$a <=> $b} grep /^\d/, @times; + map { $self->{rtts}{$_} = [@times] } @{$self->{addrlookup}{$ip}} ; + } + waitpid $pid,0; + close $inh; + close $outh; + close $errh; +} + +1; diff --git a/lib/probes/FPing.pm.orig b/lib/probes/FPing.pm.orig new file mode 100644 index 0000000..e71ceb0 --- /dev/null +++ b/lib/probes/FPing.pm.orig @@ -0,0 +1,115 @@ +package probes::FPing; + +=head1 NAME + +probes::FPing - FPing Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + FPing + binary = /usr/sepp/bin/fping + packetsize = 1024 + +=head1 DESCRIPTION + +Integrates FPing as a probe into smokeping. The variable B<binary> must +point to your copy of the FPing program. If it is not installed on +your system yet, you can get it from http://www.fping.com/. + +The (optional) packetsize option lets you configure the packetsize for the pings sent. +The FPing manpage has the following to say on this toppic: + +Number of bytes of ping data to send. The minimum size (normally 12) allows +room for the data that fping needs to do its work (sequence number, +timestamp). The reported received data size includes the IP header +(normally 20 bytes) and ICMP header (8 bytes), so the minimum total size is +40 bytes. Default is 56, as in ping. Maximum is the theoretical maximum IP +datagram size (64K), though most systems limit this to a smaller, +system-dependent number. + +=head1 AUTHOR + +Tobias Oetiker <tobi@oetiker.ch> + +=cut + +use strict; +use base qw(probes::base); +use IPC::Open3; +use Symbol; +use Carp; + +sub new($$$) +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ( $ENV{SERVER_SOFTWARE} ) { + croak "ERROR: FPing packetsize must be between 12 and 64000" + if $self->{properties}{packetsize} and + ( $self->{properties}{packetsize} < 12 or $self->{properties}{packetsize} > 64000 ); + + croak "ERROR: FPing 'binary' not defined in FPing probe definition" + unless defined $self->{properties}{binary}; + + croak "ERROR: FPing 'binary' does not point to an executable" + unless -f $self->{properties}{binary} and -x $self->{properties}{binary}; + + my $return = `$self->{properties}{binary} -C 1 localhost 2>&1`; + croak "ERROR: FPing must be installed setuid root or it will not work\n" + if $return =~ m/only.+root/; + + if ($return =~ m/bytes, ([0-9.]+)\sms\s+.*\n.*\n.*:\s+([0-9.]+)/){ + $self->{pingfactor} = 1000 * $2/$1; + print "### fping seems to report in ", $1/$2, " miliseconds\n"; + } else { + $self->{pingfactor} = 1000; # Gives us a good-guess default + print "### assuming you are using an fping copy reporting in miliseconds\n"; + } + }; + + return $self; +} + +sub ProbeDesc($){ + my $self = shift; + my $bytes = $self->{properties}{packetsize} || 56; + return "ICMP Echo Pings ($bytes Bytes)"; +} + +sub ping ($){ + my $self = shift; + # do NOT call superclass ... the ping method MUST be overwriten + my %upd; + my $inh = gensym; + my $outh = gensym; + my $errh = gensym; + # pinging nothing is pointless + return unless @{$self->addresses}; + my @bytes = () ; + push @bytes, "-b$self->{properties}{packetsize}" if $self->{properties}{packetsize}; + my $pid = open3($inh,$outh,$errh, + $self->{properties}{binary}, @bytes, + '-C', $self->{cfg}{Database}{pings}, '-q','-B1','-i10','-r1', + @{$self->addresses}); + $self->{rtts}={}; + while (<$errh>){ + chomp; + next unless /^\S+\s+:\s+[\d\.]/; #filter out error messages from fping + my @times = split /\s+/; + my $ip = shift @times; + next unless ':' eq shift @times; #drop the colon + + @times = map {sprintf "%.10e", $_ / $self->{pingfactor}} sort {$a <=> $b} grep /^\d/, @times; + map { $self->{rtts}{$_} = [@times] } @{$self->{addrlookup}{$ip}} ; + } + waitpid $pid,0; + close $inh; + close $outh; + close $errh; +} + +1; diff --git a/lib/probes/FPing6.pm b/lib/probes/FPing6.pm new file mode 100644 index 0000000..7a03b48 --- /dev/null +++ b/lib/probes/FPing6.pm @@ -0,0 +1,91 @@ +package probes::FPing6; + +=head1 NAME + +probes::FPing6 - FPing6 Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + FPing6 + binary = /usr/sbin/fping6 + +=head1 DESCRIPTION + +Integrates FPing6 as a probe into smokeping. The variable B<binary> must +point to your copy of the FPing6 program. If it is not installed on +your system yet, you can get it from http://www.fping.com/. + +=head1 AUTHOR + +Tobias Oetiker <tobi@oetiker.ch> + +=cut + +use strict; +use base qw(probes::base); +use IPC::Open3; +use Symbol; +use Carp; + +sub new($$$) +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + croak "ERROR: FPing6 'binary' not defined in FPing6 probe definition" + unless defined $self->{properties}{binary}; + + croak "ERROR: FPing6 'binary' does not point to an executable" + unless -f $self->{properties}{binary} and -x $self->{properties}{binary}; + + $_ = `$self->{properties}{binary} -C 1 localhost 2>&1`; + croak "ERROR: FPing6 must be installed setuid root or it will not work\n" if m/only.+root/; + if (m/bytes, ([0-9.]+)\sms\s+.*\n.*\n.*:\s+([0-9.]+)/){ + $self->{pingfactor} = 1000 * $2/$1; + print "### fping6 seems to report in ", $1/$2, " miliseconds\n" unless $ENV{SERVER_SOFTWARE}; + } else { + $self->{pingfactor} = 1000; # Gives us a good-guess default + print "### assuming you are using an fping6 copy reporting in miliseconds\n" unless $ENV{SERVER_SOFTWARE}; + }; + return $self; +} + +sub ProbeDesc($){ + return "IPv6-ICMP Echo Pings"; +} + +sub ping ($){ + my $self = shift; + # do NOT call superclass ... the ping method MUST be overwriten + my %upd; + my $inh = gensym; + my $outh = gensym; + my $errh = gensym; + # pinging nothing is pointless + return unless @{$self->addresses}; + my @cmd = ( + $self->{properties}{binary}, + '-C', $self->pings, '-q', + @{$self->addresses}); + $self->do_debug("Executing @cmd"); + my $pid = open3($inh,$outh,$errh, @cmd); + $self->{rtts}={}; + while (<$errh>){ + chomp; + next unless /^\S+\s+:\s+[\d\.]/; #filter out error messages from fping + my @times = split /\s+/; + my $ip = shift @times; + next unless ':' eq shift @times; #drop the colon + + @times = map {sprintf "%.10e", $_ / $self->{pingfactor}} sort {$a <=> $b} grep {$_ ne "-"} @times; + map { $self->{rtts}{$_} = [@times] } @{$self->{addrlookup}{$ip}} ; + } + waitpid $pid,0; + close $inh; + close $outh; + close $errh; +} + +1; diff --git a/lib/probes/IOSPing.pm b/lib/probes/IOSPing.pm new file mode 100644 index 0000000..3b71148 --- /dev/null +++ b/lib/probes/IOSPing.pm @@ -0,0 +1,232 @@ +package probes::IOSPing; + +=head1 NAME + +probes::IOSPing - Cisco IOS Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + IOSPing + binary = /usr/bin/remsh + packetsize = 1024 + forks = 1 + + ++ PROBE_CONF + ioshost = router + iosuser = user + iosint = source_address + +=head1 DESCRIPTION + +Integrates Cisco IOS as a probe into smokeping. Uses the rsh / remsh +protocol to run a ping from an IOS device. + +=head1 OPTIONS + +The binary and ioshost options are mandatory. + +The binary option specifies the path of the binary to be used to +connect to the IOS device. Commonly used binaries are /usr/bin/rsh +and /usr/bin/remsh, although any script or binary should work if can +be called as + + /path/to/binary [ -l user ] router ping + +to produce the IOS ping dialog on stdin & stdout. + +The (optional) packetsize option lets you configure the packetsize for +the pings sent. + +The (optional) forks options lets you configure the number of +simultaneous remote pings to be run. NB Some IOS devices have a +maximum of 5 VTYs available, so be careful not to hit a limit. + +The ioshost option specifies the IOS device which should be used for +the ping. + +The (optional) iosuser option allows you to specify the remote +username the IOS device. If this option is omitted, the username +defaults to the default user used by the remsh command (usually the +user running the remsh command, ie the user running SmokePing). + +The (optional) iosint option allows you to specify the source address +or interface in the IOS device. The value should be an IP address or +an interface name such as "Ethernet 1/0". If this option is omitted, +the IOS device will pick the IP address of the outbound interface to +use. + +=head1 IOS CONFIGURATION + +The IOS device must have rsh enabled and an appropriate trust defined, +eg: + + ! + ip rcmd rsh-enable + ip rcmd remote-host smoke 192.168.1.2 smoke enable + ! + +=head1 NOTES + +=head2 Password authentication + +It is not possible to use password authentication with rsh or remsh +due to fundamental limitations of the protocol. + +=head2 Ping packet size + +The FPing manpage has the following to say on the topic of ping packet +size: + +Number of bytes of ping data to send. The minimum size (normally 12) +allows room for the data that fping needs to do its work (sequence +number, timestamp). The reported received data size includes the IP +header (normally 20 bytes) and ICMP header (8 bytes), so the minimum +total size is 40 bytes. Default is 56, as in ping. Maximum is the +theoretical maximum IP datagram size (64K), though most systems limit +this to a smaller, system-dependent number. + +=head1 AUTHOR + +Paul J Murphy <paul@murph.org> + +based on probes::FPing by + +Tobias Oetiker <tobi@oetiker.ch> + +=cut + +use strict; +use base qw(probes::basefork); +use IPC::Open2; +use Symbol; +use Carp; + +sub new($$$) +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ( $ENV{SERVER_SOFTWARE} ) { + croak "ERROR: IOSPing packetsize must be between 12 and 64000" + if $self->{properties}{packetsize} and + ( $self->{properties}{packetsize} < 12 or $self->{properties}{packetsize} > 64000 ); + + croak "ERROR: IOSPing 'binary' not defined in IOSPing probe definition" + unless defined $self->{properties}{binary}; + + croak "ERROR: IOSPing 'binary' does not point to an executable" + unless -f $self->{properties}{binary} and -x $self->{properties}{binary}; + + $self->{pingfactor} = 1000; # Gives us a good-guess default + print "### assuming you are using an IOS reporting in miliseconds\n"; + }; + + return $self; +} + +sub ProbeDesc($){ + my $self = shift; + my $bytes = $self->{properties}{packetsize} || 56; + return "Cisco IOS - ICMP Echo Pings ($bytes Bytes)"; +} + +sub pingone ($$){ + my $self = shift; + my $target = shift; + my $bytes = $self->{properties}{packetsize} || 56; + # do NOT call superclass ... the ping method MUST be overwriten + my %upd; + my $inh = gensym; + my $outh = gensym; + my @args = (); + my $pings = $self->pings($target); + + croak "ERROR: IOSPing 'ioshost' not defined" + unless defined $target->{vars}{ioshost}; + + push(@args,$self->{properties}{binary}); + push(@args,'-l',$target->{vars}{iosuser}) + if defined $target->{vars}{iosuser}; + push(@args,$target->{vars}{ioshost}); + push(@args,'ping'); + + my $pid = open2($outh,$inh,@args); + # + # The following comments are the dialog produced by + # "remsh <router> ping" to a Cisco 800 series running IOS 12.2T + # + # Other hardware or versions of IOS may need adjustments here. + # + # Protocol [ip]: + print { $inh } "\n"; + # Target IP address: + print { $inh } $target->{addr},"\n"; + # Repeat count [5]: + print { $inh } $pings,"\n"; + # Datagram size [100]: + print { $inh } $bytes,"\n"; + # Timeout in seconds [2]: + print { $inh } "\n"; + # Extended commands [n]: + print { $inh } "y\n"; + # Source address or interface: + print { $inh } "".($target->{vars}{iosint} || "") ,"\n"; + # Added by Mars Wei to make + # Source address an option + # Type of service [0]: + print { $inh } "\n"; + # Set DF bit in IP header? [no]: + print { $inh } "\n"; + # Validate reply data? [no]: + print { $inh } "\n"; + # Data pattern [0xABCD]: + print { $inh } "\n"; + # Loose, Strict, Record, Timestamp, Verbose[none]: + print { $inh } "V\n"; + # Loose, Strict, Record, Timestamp, Verbose[V]: + print { $inh } "\n"; + # Sweep range of sizes [n]: + print { $inh } "\n"; + # + # Type escape sequence to abort. + # Sending 20, 56-byte ICMP Echos to 192.168.1.2, timeout is 2 seconds: + # Reply to request 0 (4 ms) + # Reply to request 1 (4 ms) + # Reply to request 2 (4 ms) + # Reply to request 3 (1 ms) + # Reply to request 4 (1 ms) + # Reply to request 5 (1 ms) + # Reply to request 6 (4 ms) + # Reply to request 7 (4 ms) + # Reply to request 8 (4 ms) + # Reply to request 9 (4 ms) + # Reply to request 10 (1 ms) + # Reply to request 11 (1 ms) + # Reply to request 12 (1 ms) + # Reply to request 13 (1 ms) + # Reply to request 14 (4 ms) + # Reply to request 15 (4 ms) + # Reply to request 16 (4 ms) + # Reply to request 17 (4 ms) + # Reply to request 18 (1 ms) + # Reply to request 19 (1 ms) + # Success rate is 100 percent (20/20), round-trip min/avg/max = 1/2/4 ms + + my @times = (); + while (<$outh>){ + chomp; + /^Reply to request \d+ \((\d+) ms\)/ && push(@times,$1); + } + @times = map {sprintf "%.10e", $_ / $self->{pingfactor}} sort {$a <=> $b} @times; + + waitpid $pid,0; + close $inh; + close $outh; + + return @times; +} + +1; diff --git a/lib/probes/LDAP.pm b/lib/probes/LDAP.pm new file mode 100644 index 0000000..b7e5342 --- /dev/null +++ b/lib/probes/LDAP.pm @@ -0,0 +1,184 @@ +package probes::LDAP; + +=head1 NAME + +probes::LDAP - a LDAP probe for SmokePing + +=head1 OVERVIEW + +Measures LDAP search latency for SmkoePing + +=head1 SYNOPSYS + + *** Probes *** + + LDAP + + passwordfile = /usr/share/smokeping/etc/password # optional + sleeptime = 0.5 # optional, 1 second by default + + *** Targets *** + + probe = LDAP + + + PROBE_CONF + port = 389 # optional + version = 3 # optional + start_tls = 1 # disabled by default + timeout = 60 # optional + + base = dc=foo,dc=bar # optional + filter = uid=testuser # the actual search + attrs = uid,someotherattr + + # if binddn isn't present, the LDAP bind is unauthenticated + binddn = uid=testuser,dc=foo,dc=bar + password = mypass # if not present in <passwordfile> + +=head1 DESCRIPTION + +This probe measures LDAP query latency for SmokePing. +The query is specified by the target-specific variable `filter' and, +optionally, by the target-specific variable `base'. The attributes +queried can be specified in the comma-separated list `attrs'. + +The TCP port of the LDAP server and the LDAP version to be used can +be specified by the variables `port' and `version'. + +The probe can issue the starttls command to convert the connection +into encrypted mode, if so instructed by the `start_tls' variable. +It can also optionally do an authenticated LDAP bind, if the `binddn' +variable is present. The password to be used can be specified by the +target-specific variable `password' or in an external file. +The location of this file is given in the probe-specific variable +`passwordfile'. See probes::passwordchecker(3pm) for the format +of this file (summary: colon-separated triplets of the form +`<host>:<bind-dn>:<password>') + +The probe tries to be nice to the server and sleeps for the probe-specific +variable `sleeptime' (one second by default) between each authentication +request. + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 BUGS + +There should be a way of specifying TLS options, such as the certificates +involved etc. + +The probe has an ugly way of working around the fact that the +IO::Socket::SSL class complains if start_tls() is done more than once +in the same program. But It Works For Me (tm). + +=cut + +use strict; +use probes::passwordchecker; +use Net::LDAP; +use Time::HiRes qw(gettimeofday sleep); +use base qw(probes::passwordchecker); +use IO::Socket::SSL; + +sub ProbeDesc { + return "LDAP queries"; +} + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + my $sleeptime = $self->{properties}{sleeptime}; + $sleeptime = 1 unless defined $sleeptime; + $self->sleeptime($sleeptime); + + return $self; +} + +sub sleeptime { + my $self = shift; + my $newval = shift; + + $self->{sleeptime} = $newval if defined $newval; + return $self->{sleeptime}; +} + + +sub pingone { + my $self = shift; + my $target = shift; + my $host = $target->{addr}; + my $vars = $target->{vars}; + + my $version = $vars->{version} || 3; + my $port = $vars->{port}; + + my $binddn = $vars->{binddn}; + + my $timeout = $vars->{timeout}; + + my $password = $vars->{password} || $self->password($host, $binddn) if defined $binddn; + + my $start_tls = $vars->{start_tls}; + + my $filter = $vars->{filter}; + + my $base = $vars->{base}; + + my $attrs = $vars->{attrs}; + + my @attrs = split(/,/, $attrs); + + my @times; + + for (1..$self->pings($target)) { + local $IO::Socket::SSL::SSL_Context_obj; # ugly but necessary + sleep $self->sleeptime unless $_ == 1; # be nice + my $start = gettimeofday(); + my $ldap = new Net::LDAP($host, port => $port, version => $version, timeout => $timeout) + or do { + $self->do_log("connection error on $host: $!"); + next; + }; + my $mesg; + if ($start_tls) { + $mesg = $ldap->start_tls; + $mesg->code and do { + $self->do_log("start_tls error on $host: " . $mesg->error); + $ldap->unbind; + next; + } + } + if (defined $binddn and defined $password) { + $mesg = $ldap->bind($binddn, password => $password); + } else { + if (defined $binddn and not defined $password) { + $self->do_debug("No password specified for $binddn, doing anonymous bind instead"); + } + $mesg = $ldap->bind(); + } + $mesg->code and do { + $self->do_log("bind error on $host: " . $mesg->error); + $ldap->unbind; + next; + }; + $mesg = $ldap->search(base => $base, filter => $filter, attrs => [ @attrs ]); + $mesg->code and do { + $self->do_log("filter error on $host: " . $mesg->error); + $ldap->unbind; + next; + }; + $ldap->unbind; + my $end = gettimeofday(); + my $elapsed = $end - $start; + + $self->do_debug("$host: LDAP query $_ took $elapsed seconds"); + + push @times, $elapsed; + } + return sort { $a <=> $b } @times; +} + + +1; diff --git a/lib/probes/Radius.pm b/lib/probes/Radius.pm new file mode 100644 index 0000000..2c4fb96 --- /dev/null +++ b/lib/probes/Radius.pm @@ -0,0 +1,184 @@ +package probes::Radius; + +=head1 NAME + +probes::Radius - a RADIUS authentication probe for SmokePing + +=head1 OVERVIEW + +Measures RADIUS authentication latency for SmokePing + +=head1 SYNOPSYS + + *** Probes *** + + Radius + + passwordfile = /usr/share/smokeping/etc/password + secretfile = /etc/raddb/secret + sleeptime = 0.5 # optional, 1 second by default + username = test-user # optional, overridden by target + password = test-password # optional, overridden by target + secret = test-secret # optional, overridden by target + + *** Targets *** + + probe = Radius + + + PROBE_CONF + username = testuser + secret = myRadiusSecret # if not present in <secretfile> + password = testuserPass # if not present in <passwordfile> + port = 1645 # optional + nas_ip_address = 1.2.3.4 # optional + +=head1 DESCRIPTION + +This probe measures RADIUS (RFC 2865) authentication latency for SmokePing. + +The username to be tested is specified in either the probe-specific or the +target-specific variable `username', with the target-specific one overriding +the probe-specific one. + +The password can be specified either (in order of precedence, with the latter +overriding the former) in the probe-specific variable `password', in the +target-specific variable `password' or in an external file. The location of +this file is given in the probe-specific variable `passwordfile'. See +probes::passwordchecker(3pm) for the format of this file (summary: +colon-separated triplets of the form `<host>:<username>:<password>') + +The RADIUS protocol requires a shared secret between the server and the client. +This secret can be specified either (in order of precedence, with the latter +overriding the former) in the probe-specific variable `secret', in the +target-specific variable `secret' or in an external file. +This external file is located by the probe-specific variable `secretfile', and it should +contain whitespace-separated pairs of the form `<host> <secret>'. Comments and blank lines +are OK. + +If the optional probe-specific variable `nas_ip_address' is specified, its +value is inserted into the authentication requests as the `NAS-IP-Address' +RADIUS attribute. + +The probe tries to be nice to the server and sleeps for the probe-specific +variable `sleeptime' (one second by default) between each authentication +request. + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 BUGS + +There should be a more general way of specifying RADIUS attributes. + +=cut + +use strict; +use probes::passwordchecker; +use base qw(probes::passwordchecker); +use Authen::Radius; +use Time::HiRes qw(gettimeofday sleep); +use Carp; + +sub ProbeDesc { + return "RADIUS queries"; +} + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ($ENV{SERVER_SOFTWARE}) { + if (defined $self->{properties}{secretfile}) { + open(S, "<$self->{properties}{secretfile}") + or croak("Error opening specified secret file $self->{properties}{secretfile}: $!"); + while (<S>) { + chomp; + next unless /\S/; + next if /^\s*#/; + my ($host, $secret) = split; + carp("Line $. in $self->{properties}{secretfile} is invalid"), next + unless defined $host and defined $secret; + $self->secret($host, $secret); + } + close S; + } + + my $sleeptime = $self->{properties}{sleeptime}; + $sleeptime = 1 unless defined $sleeptime; + $self->sleeptime($sleeptime); + + } + + return $self; +} + +sub secret { + my $self = shift; + my $host = shift; + my $newval = shift; + + $self->{secret}{$host} = $newval if defined $newval; + return $self->{secret}{$host}; +} + +sub sleeptime { + my $self = shift; + my $newval = shift; + + $self->{sleeptime} = $newval if defined $newval; + return $self->{sleeptime}; +} + +sub pingone { + my $self = shift; + my $target = shift; + my $host = $target->{addr}; + my $vars = $target->{vars}; + my $username = $vars->{username} || $self->{properties}->{username}; + my $secret = $vars->{secret} || $self->secret($host) || $self->{properties}->{secret}; + + $self->do_log("Missing RADIUS secret for $host"), return + unless defined $secret; + + $self->do_log("Missing RADIUS username for $host"), return + unless defined $username; + + my $password = $vars->{password} || $self->password($host, $username) || $self->{properties}->{password}; + + my $port = $vars->{port}; + $host .= ":$port" if defined $port; + + $self->do_log("Missing RADIUS password for $host/$username"), return + unless defined $password; + + my @times; + for (1..$self->pings($target)) { + my $r = new Authen::Radius(Host => $host, Secret => $secret); + $r->add_attributes( + { Name => 1, Value => $username, Type => 'string' }, + { Name => 2, Value => $password, Type => 'string' }, + ); + $r->add_attributes( { Name => 4, Type => 'ipaddr', Value => $vars->{nas_ip_address} }) + if exists $vars->{nas_ip_address}; + my $c; + my $start = gettimeofday(); + $r->send_packet(ACCESS_REQUEST) and $c = $r->recv_packet; + my $end = gettimeofday(); + my $result; + if (defined $c) { + $result = $c; + $result = "OK" if $c == ACCESS_ACCEPT; + $result = "fail" if $c == ACCESS_REJECT; + } else { + $result = "no reply"; + } + $self->do_debug("$host: radius query $_: $result, " . ($end - $start)); + push @times, $end - $start if (defined $c and $c == ACCESS_ACCEPT); + sleep $self->sleeptime; # be nice + } + return sort { $a <=> $b } @times; +} + +1; diff --git a/lib/probes/RemoteFPing.pm b/lib/probes/RemoteFPing.pm new file mode 100644 index 0000000..da87b6c --- /dev/null +++ b/lib/probes/RemoteFPing.pm @@ -0,0 +1,164 @@ +package probes::RemoteFPing; + +=head1 NAME + +probes::RemoteFPing - Remote FPing Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + RemoteFPing + binary = /usr/bin/ssh + packetsize = 1024 + rhost = HostA.foobar.com + ruser = foo + rbinary = /usr/local/sbin/fping + + *** Targets *** + + Targetname + Probe = RemoteFPing + Menu = menuname + Title = Remote Fping from HostA to HostB + Host = HostB.barfoo.com + + +=head1 DESCRIPTION + +Integrates the remote execution of FPing via ssh/rsh into smokeping. +The variable B<binary> must point to your copy of the ssh/rsh program. + +=head1 OPTIONS + +The B<binary> and B<rhost> are mandatory. The B<binary> option +specifies the path of the remote shell program (usually ssh, +rsh or remsh). Any other script or binary that can be called as + + binary [ -l ruser ] rhost rbinary + +may be used. + +The (optional) B<packetsize> option lets you configure the packetsize +for the pings sent. + +The B<rhost> option specifies the remote device from where fping will +be launched. + +The (optional) B<ruser> option allows you to specify the remote user, +if different from the one running the smokeping daemon. + +The (optional) B<rbinary> option allows you to specify the location of +the remote fping binary. If not specified the probe will assume that +fping is in the remote host's path. + +=head1 NOTES + +It is important to make sure that you can access the remote machine +without a password prompt, otherwise this probe will not work properly. +To test just try something like this: + + $ ssh foo@HostA.foobar.com fping HostB.barfoo.com + +The next thing you see must be fping's output. + +The B<rhost>, B<ruser> and B<rbinary> variables used to be configured in +the PROBE_CONF section of the first target or its parents They were moved +to the Probes section, because the variables aren't really target-specific +(all the targets are measured with the same parameters). The PROBE_CONF +sections aren't recognized anymore. + +=head1 AUTHOR + +Luis F Balbinot <hades@inf.ufrgs.br> + +based on probes::FPing by + +Tobias Oetiker <tobi@oetiker.ch> + +=cut + +use strict; +use base qw(probes::base); +use IPC::Open3; +use Symbol; +use Carp; + +sub new($$$) { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ( $ENV{SERVER_SOFTWARE} ) { + croak "ERROR: RemoteFPing packetsize must be between 12 and 64000" + if $self->{properties}{packetsize} and + ( $self->{properties}{packetsize} < 12 or $self->{properties}{packetsize} > 64000 ); + + croak "ERROR: RemoteFPing 'binary' not defined in RemoteFPing probe definition" + unless defined $self->{properties}{binary}; + + croak "ERROR: RemoteFPing 'binary' does not point to an executable" + unless -f $self->{properties}{binary} and -x $self->{properties}{binary}; + + croak "ERROR: RemoteFPing 'rhost' not defined in RemoteFPing probe definition. This might be because the configuration syntax has changed. See the RemoteFPing manual for details." + unless defined $self->{properties}{rhost}; + + $self->{pingfactor} = 1000; # Gives us a good-guess default + print "### assuming you are using a remote fping copy reporting in milliseconds\n"; + }; + + return $self; +} + +sub ProbeDesc($) { + my $self = shift; + my $bytes = $self->{properties}{packetsize} || 56; + return "Remote ICMP Echo Pings ($bytes Bytes)"; +} + +sub ping ($) { + my $self = shift; + + # do NOT call superclass ... the ping method MUST be overwriten + my %upd; + my $inh = gensym; + my $outh = gensym; + my $errh = gensym; + # pinging nothing is pointless + return unless @{$self->addresses}; + my @bytes = (); + + push @bytes, "-b$self->{properties}{packetsize}" if $self->{properties}{packetsize}; + + my @rargs; + for my $what (qw(ruser rhost rbinary)) { + my $prefix = ($what eq 'ruser' ? "-l" : ""); + if (defined $self->{properties}{$what}) { + push @rargs, $prefix . $self->{properties}{$what}; + } + } + + my $query = "$self->{properties}{binary} @rargs @bytes -C " . $self->pings . " -q -B1 -i10 -r1 @{$self->addresses}"; + + $self->do_debug("query=$query\n"); + + my $pid = open3($inh,$outh,$errh,$query ); + my @times =() ; + $self->{rtts}={}; + while (<$errh>) { + chomp; + next unless /^\S+\s+:\s+[\d\.]/; #filter out error messages from fping + $self->do_debug("array element=$_ \n"); + @times = split /\s+/; + my $ip = shift @times; + next unless ':' eq shift @times; #drop the colon + @times = map {sprintf "%.10e", $_ / $self->{pingfactor}} sort {$a <=> $b} grep {$_ ne "-"} @times; + map { $self->{rtts}{$_} = [@times] } @{$self->{addrlookup}{$ip}} ; + } + waitpid $pid,0; + close $inh; + close $outh; + close $errh; + return @times; +} + +1; diff --git a/lib/probes/SSH.pm b/lib/probes/SSH.pm new file mode 100644 index 0000000..ede9c4c --- /dev/null +++ b/lib/probes/SSH.pm @@ -0,0 +1,137 @@ +package probes::SSH; + +=head1 NAME + +probes::SSH - Secure Shell Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + SSH + binary = /usr/bin/ssh-keyscan + + *** Targets *** + probe = SSH + forks = 10 + + + First + menu = First + title = First Target + # .... + +=head1 DESCRIPTION + +Integrates ssh-keyscan as a probe into smokeping. The variable B<binary> must +point to your copy of the ssh-keyscan program. If it is not installed on +your system yet, you should install openssh >= 3.8p1 + +The Probe asks the given host n-times for it's public key. Where n is +the amount specified in the config File. + +Supported probe-specific variables: + +=over + +=item binary + +The location of your ssh-keyscan binary. + +=item forks + +The number of concurrent processes to be run. See probes::basefork(3pm) +for details. + +=back + +Supported target-level probe variables: + +=over + +=back + + +=head1 AUTHOR + +Christian Recktenwald<lt>smokeping-contact@citecs.de<gt> + + +=cut + +use strict; +use base qw(probes::basefork); +use IPC::Open3; +use Symbol; +use Carp; +use POSIX; + +my $ssh_re=qr/^# \S+ SSH-/i; + +sub new($$$) +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ( $ENV{SERVER_SOFTWARE} ) { + + croak "ERROR: SSH 'binary' not defined in SSH probe definition" + unless defined $self->{properties}{binary}; + + croak "ERROR: SSH 'binary' does not point to an executable" + unless -f $self->{properties}{binary} and -x $self->{properties}{binary}; + my $call = "$self->{properties}{binary} -t rsa localhost"; + my $return = `$call 2>&1`; + if ($return =~ m/$ssh_re/s){ + $self->{pingfactor} = 10; + print "### parsing ssh-keyscan output...OK\n"; + } else { + croak "ERROR: output of '$call' does not match $ssh_re\n"; + } + }; + + return $self; +} + +sub ProbeDesc($){ + my $self = shift; + return "SSH requests"; +} + +sub pingone ($){ + my $self = shift; + my $target = shift; + + my $inh = gensym; + my $outh = gensym; + my $errh = gensym; + + my $host = $target->{addr}; + + my $query = "$self->{properties}{binary} -t rsa $host"; + my @times; + + # get the user and system times before and after the test + $self->do_debug("query=$query\n"); + for (my $run = 0; $run < $self->pings; $run++) { + my @times1 = POSIX::times; + my $pid = open3($inh,$outh,$errh, $query); + while (<$outh>) { + if (/$ssh_re/i) { + last; + } + } + waitpid $pid,0; + close $errh; + close $inh; + close $outh; + my @times2 = POSIX::times; + push @times, $times2[0]-$times1[0]; + } + @times = map {sprintf "%.10e", $_ / $self->{pingfactor}} sort {$a <=> $b} grep {$_ ne "-"} @times; + +# $self->do_debug("time=@times\n"); + return @times; +} + +1; diff --git a/lib/probes/base.pm b/lib/probes/base.pm new file mode 100644 index 0000000..79165f1 --- /dev/null +++ b/lib/probes/base.pm @@ -0,0 +1,217 @@ +package probes::base; + +=head1 NAME + +probes::base - Base Class for implementing SmokePing Probes + +=head1 OVERVIEW + +For the time being, please use the probes::FPing for +inspiration when implementing your own probes. + +=head1 AUTHOR + +Tobias Oetiker <tobi@oetiker.ch> + +=cut + +use vars qw($VERSION); +use Carp; +use lib qw(..); +use Smokeping; + +$VERSION = 1.0; + +use strict; + +sub new($$) +{ + my $this = shift; + my $class = ref($this) || $this; + my $self = { properties => shift, cfg => shift, + name => shift, + targets => {}, rtts => {}, addrlookup => {}}; + bless $self, $class; + return $self; +} + +sub add($$) +{ + my $self = shift; + my $tree = shift; + + $self->{targets}{$tree} = shift; +} + +sub ping($) +{ + croak "this must be overridden by the subclass"; +} + +sub round ($) { + return sprintf "%.0f", $_[0]; +} + +sub ProbeDesc ($) { + return "Probe which does not overrivd the ProbeDesc methode"; +} + +sub rrdupdate_string($$) +{ my $self = shift; + my $tree = shift; +# print "$tree -> ", join ",", @{$self->{rtts}{$tree}};print "\n"; + # skip invalid addresses + my $pings = $self->_pings($tree); + return "U:${pings}:".(join ":", map {"U"} 1..($pings+1)) + unless defined $self->{rtts}{$tree} and @{$self->{rtts}{$tree}} > 0; + my $entries = scalar @{$self->{rtts}{$tree}}; + my @times = @{$self->{rtts}{$tree}}; + my $loss = $pings - $entries; + my $median = $times[int($entries/2)] || 'U'; + # shift the data into the middle of the times array + my $lowerloss = int($loss/2); + my $upperloss = $loss - $lowerloss; + @times = ((map {'U'} 1..$lowerloss),@times, (map {'U'} 1..$upperloss)); + my $age; + if ( -f $self->{targets}{$tree}.".adr" ) { + $age = time - (stat($self->{targets}{$tree}.".adr"))[9]; + } else { + $age = 'U'; + } + if ( $entries == 0 ){ + $age = 'U'; + $loss = 'U'; + if ( -f $self->{targets}{$tree}.".adr" + and not -f $self->{targets}{$tree}.".snmp" ){ + unlink $self->{targets}{$tree}.".adr"; + } + } ; + return "${age}:${loss}:${median}:".(join ":", @times); +} + +sub addresses($) +{ + my $self = shift; + my $addresses = []; + $self->{addrlookup} = {}; + foreach my $tree (keys %{$self->{targets}}){ + my $target = $self->{targets}{$tree}; + if ($target =~ m|/|) { + if ( open D, "<$target.adr" ) { + my $ip; + chomp($ip = <D>); + close D; + + if ( open D, "<$target.snmp" ) { + my $snmp = <D>; + chomp($snmp); + if ($snmp ne Smokeping::snmpget_ident $ip) { + # something fishy snmp properties do not match, skip this address + next; + } + close D; + } + $target = $ip; + } else { + # can't read address file skip + next; + } + } + $self->{addrlookup}{$target} = () + unless defined $self->{addrlookup}{$target}; + push @{$self->{addrlookup}{$target}}, $tree; + push @{$addresses}, $target; + }; + return $addresses; +} + +sub debug { + my $self = shift; + my $newval = shift; + $self->{debug} = $newval if defined $newval; + return $self->{debug}; +} + +sub do_debug { + my $self = shift; + return unless $self->debug; + $self->do_log(@_); +} + +sub do_fatal { + my $self = shift; + $self->do_log("Fatal:", @_); + croak(@_); +} + +sub do_log { + my $self = shift; + Smokeping::do_log("$self->{name}:", @_); +} + +sub report { + my $self = shift; + my $count = $self->target_count; + my $offset = $self->offset_in_seconds; + my $step = $self->step; + $self->do_log("probing $count targets with step $step s and offset $offset s."); +} + +sub step { + my $self = shift; + my $rv = $self->{cfg}{Database}{step}; + unless (defined $self->{cfg}{General}{concurrentprobes} + and $self->{cfg}{General}{concurrentprobes} eq 'no') { + $rv = $self->{properties}{step} if defined $self->{properties}{step}; + } + return $rv; +} + +sub offset { + my $self = shift; + my $rv = $self->{cfg}{General}{offset}; + unless (defined $self->{cfg}{General}{concurrentprobes} + and $self->{cfg}{General}{concurrentprobes} eq 'no') { + $rv = $self->{properties}{offset} if defined $self->{properties}{offset}; + } + return $rv; +} + +sub offset_in_seconds { + # returns the offset in seconds rather than as a percentage + # this is filled in from the initialization in Smokeping::main + my $self = shift; + my $newval = shift; + $self->{offset_in_seconds} = $newval if defined $newval; + return $self->{offset_in_seconds}; +} + +# the "public" method that takes a "target" argument is used by the probes +# the "private" method that takes a "tree" argument is used by Smokeping.pm +# there's no difference between them here, but we have to provide both + +sub pings { + my $self = shift; + my $target = shift; + # $target is not used; basefork.pm overrides this method to provide a target-specific parameter + my $rv = $self->{cfg}{Database}{pings}; + $rv = $self->{properties}{pings} if defined $self->{properties}{pings}; + return $rv; +} + + +sub _pings { + my $self = shift; + my $tree = shift; + # $tree is not used; basefork.pm overrides this method to provide a target-specific parameter + my $rv = $self->{cfg}{Database}{pings}; + $rv = $self->{properties}{pings} if defined $self->{properties}{pings}; + return $rv; +} + +sub target_count { + my $self = shift; + return scalar keys %{$self->{targets}}; +} + +1; diff --git a/lib/probes/basefork.pm b/lib/probes/basefork.pm new file mode 100644 index 0000000..9fd3f14 --- /dev/null +++ b/lib/probes/basefork.pm @@ -0,0 +1,242 @@ +package probes::basefork; + +my $DEFAULTFORKS = 5; + +=head1 NAME + +probes::basefork - Yet Another Base Class for implementing SmokePing Probes + +=head1 OVERVIEW + +Like probes::basevars, but supports the probe-specific property `forks' +to determine how many processes should be run concurrently. The +targets are pinged one at a time, and the number of pings sent can vary +between targets. + +=head1 SYNOPSYS + + *** Probes *** + + + MyForkingProbe + # run this many concurrent processes + forks = 10 + # how long does a single 'ping' take + timeout = 10 + # how many pings to send + pings = 10 + + + MyOtherForkingProbe + # we don't want any concurrent processes at all for some reason. + forks = 1 + + *** Targets *** + + menu = First + title = First + host = firsthost + probe = MyForkingProbe + + menu = Second + title = Second + host = secondhost + probe = MyForkingProbe + +PROBE_CONF + pings = 20 + +=head1 DESCRIPTION + +Not all pinger programs support testing multiple hosts in a single go like +fping(1). If the measurement takes long enough, there may be not enough time +perform all the tests in the time available. For example, if the test takes +30 seconds, measuring ten hosts already fills up the SmokePing default +five minute step. + +Thus, it may be necessary to do some of the tests concurrently. This module +defines the B<ping> method that forks the requested number of concurrent +processes and calls the B<pingone> method that derived classes must provide. + +The B<pingone> method is called with one argument: a hash containing +the target that is to be measured. The contents of the hash are +described in I<probes::basevars>(3pm). + +The number of concurrent processes is determined by the probe-specific +variable `forks' and is 5 by default. If there are more +targets than this value, another round of forks is done after the first +processes are finished. This continues until all the targets have been +tested. + +The timeout in which each child has to finish is set to 5 seconds +multiplied by the maximum number of 'pings' of the targets. You can set +the base timeout differently if you want to, using the timeout property +of the probe in the master config file (this again will be multiplied +by the maximum number of pings). The probe itself can also override the +default by providing a TimeOut method which returns an integer. + +If the child isn't finished when the timeout occurs, it +will be killed along with any processes it has started. + +The number of pings sent can be specified in the probe-specific variable +'pings', and it can be overridden by each target in the 'PROBE_CONF' +section. + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 BUGS + +The timeout code has only been tested on Linux. + +=head1 SEE ALSO + +probes::basevars(3pm), probes::EchoPing(3pm) + +=cut + +use strict; +use base qw(probes::basevars); +use Symbol; +use Carp; +use IO::Select; +use POSIX; # for ceil() and floor() +use Config; # for signal names + +my %signo; +my @signame; + +{ + # from perlipc man page + my $i = 0; + defined $Config{sig_name} || die "No sigs?"; + foreach my $name (split(' ', $Config{sig_name})) { + $signo{$name} = $i; + $signame[$i] = $name; + $i++; + } +} + +die("Missing TERM signal?") unless exists $signo{TERM}; +die("Missing KILL signal?") unless exists $signo{KILL}; + +sub pingone { + croak "pingone: this must be overridden by the subclass"; +} + +sub TimeOut { + # probes which require more time may want to provide their own implementation. + return 5; +} + +sub ping { + my $self = shift; + + my @targets = @{$self->targets}; + return unless @targets; + + my $forks = $self->{properties}{forks} || $DEFAULTFORKS; + + my $timeout = $self->{properties}{timeout}; + unless (defined $timeout and $timeout > 0) { + my $maxpings = 0; + for (@targets) { + my $p = $self->pings($_); + $maxpings = $p if $p > $maxpings; + } + $timeout = $maxpings * $self->TimeOut(); + } + + $self->{rtts}={}; + $self->do_debug("forks $forks, timeout per target $timeout"); + + while (@targets) { + my %targetlookup; + my %pidlookup; + my $s = IO::Select->new(); + my $starttime = time(); + for (1..$forks) { + last unless @targets; + my $t = pop @targets; + my $pid; + my $handle = gensym; + my $sleep_count = 0; + do { + $pid = open($handle, "-|"); + + unless (defined $pid) { + $self->do_log("cannot fork: $!"); + $self->fatal("bailing out") + if $sleep_count++ > 6; + sleep 10; + } + } until defined $pid; + if ($pid) { #parent + $s->add($handle); + $targetlookup{$handle} = $t; + $pidlookup{$handle} = $pid; + } else { #child + # we detach from the parent's process group + setpgrp(0, $$); + + my @times = $self->pingone($t); + print join(" ", @times), "\n"; + exit; + } + } + my $timeleft = $timeout - (time() - $starttime); + + while ($s->handles and $timeleft > 0) { + for my $ready ($s->can_read($timeleft)) { + $s->remove($ready); + my $response = <$ready>; + close $ready; + + chomp $response; + my @times = split(/ /, $response); + my $target = $targetlookup{$ready}; + my $tree = $target->{tree}; + $self->{rtts}{$tree} = \@times; + + $self->do_debug("$target->{addr}: got $response"); + } + $timeleft = $timeout - (time() - $starttime); + } + my @left = $s->handles; + for my $handle (@left) { + $self->do_log("$targetlookup{$handle}{addr}: timeout ($timeout s) reached, killing the probe."); + + # we kill the child's process group (negative signal) + # this should finish off the actual pinger process as well + + my $pid = $pidlookup{$handle}; + kill -$signo{TERM}, $pid; + sleep 1; + kill -$signo{KILL}, $pid; + + close $handle; + $s->remove($handle); + } + } +} + +# the "private" method that takes a "tree" argument is used by Smokeping.pm +sub _pings { + my $self = shift; + my $tree = shift; + my $vars = $self->vars($tree); + return $vars->{pings} if defined $vars->{pings}; + return $self->SUPER::pings(); +} + +# the "public" method that takes a "target" argument is used by the probes +sub pings { + my $self = shift; + my $target = shift; + return $self->SUPER::pings() unless ref $target; + return $self->_pings($target->{tree}); +} + +sub ProbeDesc { + return "Probe that can fork and doesn't override the ProbeDesc method"; +} + +1; diff --git a/lib/probes/basevars.pm b/lib/probes/basevars.pm new file mode 100644 index 0000000..19f21e0 --- /dev/null +++ b/lib/probes/basevars.pm @@ -0,0 +1,119 @@ +package probes::basevars; + +=head1 NAME + +probes::basevars - Another Base Class for implementing SmokePing Probes + +=head1 OVERVIEW + +Like probes::base, but supports host-specific variables for the probe. + +=head1 SYNOPSIS + + *** Targets *** + + menu = Top + title = Top Page + + + branch_1 + menu = First menu + title = First title + host = host1 + ++ PROBE_CONF + # vars for host host1 + var1 = foo + var2 = bar + + ++ branch_1_2 + menu = Second menu + title = Second title + host = host2 + +++ PROBE_CONF + # vars for host host2 + # var1 and var2 are propagated from above, override var2 + var2 = fii + + + branch_2 + # var1 and var2 are undefined here + +=head1 DESCRIPTION + +Provides the method `targets' that returns a list of hashes. +The hashes contain the entries: + +=over + +=item addr + +The address of the target. + +=item vars + +A hash containing variables defined in the corresponding +`PROBE_CONF' config section. + +=item tree + +The unique index that `probe::base' uses for targets. + +There's also the method 'vars' that returns the abovementioned +hash corresponding to the 'tree' index parameter. + +=back + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 BUGS + +Uses `probes::base' internals too much to be a derived class, but +I didn't want to touch the base class directly. + +=head1 SEE ALSO + +probes::base(3pm), probes::EchoPing(3pm) + +=cut + +use strict; +use probes::base; +use base qw(probes::base); + +sub add($$) +{ + my $self = shift; + my $tree = shift; + + $self->{targets}{$tree} = shift; + $self->{PROBE_CONF}{$tree} = $tree->{PROBE_CONF}; +} + +sub targets { + my $self = shift; + my $addr = $self->addresses; + my @targets; + + # copy the addrlookup lists to safely pop + my %copy; + + for (@$addr) { + @{$copy{$_}} = @{$self->{addrlookup}{$_}} unless exists $copy{$_}; + my $tree = pop @{$copy{$_}}; + push @targets, { addr => $_, vars => $self->{PROBE_CONF}{$tree}, + tree => $tree }; + } + return \@targets; +} + +sub vars { + my $self = shift; + my $tree = shift; + return $self->{PROBE_CONF}{$tree}; +} + +sub ProbeDesc { + return "Probe that supports variables and doesn't override the ProbeDesc method"; +} + +return 1; diff --git a/lib/probes/passwordchecker.pm b/lib/probes/passwordchecker.pm new file mode 100644 index 0000000..8fad4f9 --- /dev/null +++ b/lib/probes/passwordchecker.pm @@ -0,0 +1,116 @@ +package probes::passwordchecker; + +=head1 NAME + +probes::passwordchecker - A Base Class for implementing SmokePing Probes + +=head1 OVERVIEW + +Like probes::basefork, but supports a probe-specific configuration file +for storing passwords and a method for accessing them. + +=head1 SYNOPSYS + +SmokePing main configuration file: + + *** Probes *** + + MyPasswordChecker + # location of the file containing usernames and passwords + passwordfile = /usr/share/smokeping/etc/passwords + +The specified password file: + + # host:username:password + host1:joe:hardlyasecret + # comments and whitespace lines are allowed + + host2:sue:notasecreteither + +=head1 DESCRIPTION + +In implementing authentication probes, it might not be desirable to store +the necessary cleartext passwords in the SmokePing main configuration +file, since the latter must be readable both by the SmokePing daemon +performing the probes and the CGI that displays the results. If the +passwords are stored in a different file, this file can be made readable +by only the user the daemon runs as. This way we can be sure that nobody +can trick the CGI into displaying the passwords on the Web. + +This module reads the passwords in at startup from the file specified +in the probe-specific variable `passwordfile'. The passwords can later +be accessed and modified by the B<password> method, that needs the corresponding +host and username as arguments. + +=head1 PASSWORD FILE FORMAT + +The password file format is simply one line for each triplet of host, +username and password, separated from each other by colons (:). + +Comment lines, starting with the `#' sign, are ignored, as well as +empty lines. + +=head1 AUTHOR + +Niko Tyni E<lt>ntyni@iki.fiE<gt> + +=head1 BUGS + +The need for storing cleartext passwords can be considered a bug in itself. + +=head1 SEE ALSO + +probes::basefork(3pm), probes::Radius(3pm), probes::LDAP(3pm) + +=cut + +use strict; +use probes::basefork; +use base qw(probes::basefork); +use Carp; + +sub ProbeDesc { + return "probe that can fork, knows about passwords and doesn't override the ProbeDesc method"; +} + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ($ENV{SERVER_SOFTWARE}) { + + if (defined $self->{properties}{passwordfile}) { + my @stat = stat($self->{properties}{passwordfile}); + my $mode = $stat[2]; + carp("Warning: password file $self->{properties}{passwordfile} is world-readable\n") + if defined $mode and $mode & 04; + + open(P, "<$self->{properties}{passwordfile}") + or croak("Error opening specified password file $self->{properties}{passwordfile}: $!"); + while (<P>) { + chomp; + next unless /\S/; + next if /^\s*#/; + my ($host, $username, $password) = split(/:/); + carp("Line $. in $self->{properties}{passwordfile} is invalid"), next unless defined $host and defined $username and defined $password; + $self->password($host, $username, $password); + } + close P; + } + } + + + return $self; +} + +sub password { + my $self = shift; + my $host = shift; + my $username = shift; + my $newval = shift; + $self->{password}{$host}{$username} = $newval if defined $newval; + return $self->{password}{$host}{$username}; +} + +1; diff --git a/lib/probes/telnetIOSPing.pm b/lib/probes/telnetIOSPing.pm new file mode 100644 index 0000000..e591563 --- /dev/null +++ b/lib/probes/telnetIOSPing.pm @@ -0,0 +1,255 @@ +package probes::telnetIOSPing; + +=head1 NAME + +probes::telnetIOSPing - Cisco IOS Probe for SmokePing + +=head1 SYNOPSIS + + *** Probes *** + + telnetIOSPing + packetsize = 56 + forks = 1 + + ++ PROBE_CONF + iospass = password + iosuser = user + target = 192.168.1.1 + source = 192.168.2.1 + psource = 192.168.2.129 + +=head1 DESCRIPTION + +Integrates Cisco IOS as a probe into smokeping. Uses the telnet protocol +to run a ping from an IOS device (source) to another device (target). +This probe basically uses the "extended ping" of the Cisco IOS. You have +the option to specify which interface the ping is sourced from as well. + +=head1 OPTIONS + +The iosuser, iospass, source, and target options are mandatory. + +The (optional) packetsize option lets you configure the packetsize for +the pings sent. The default size is 56. + +The (optional) forks options lets you configure the number of +simultaneous remote pings to be run. NB Some IOS devices have a +maximum of 5 VTYs available, so be careful not to hit a limit. + +The source option specifies the IOS device to which we telnet. This +is an IP address of an IOS Device that you/your server: + 1) Have the ability to telnet to + 2) Have a valid username and password for + +The target option specifies the device you wish to ping from your IOS +Device. + +The (optional) psource option specifies an alternate IP address or +Interface from which you wish to source your pings from. Routers +can have many many IP addresses, and interfaces. When you ping from a +router you have the ability to choose which interface and/or which IP +address the ping is sourced from. Specifying an IP/interface does not +necessarily specify the interface from which the ping will leave, but +will specify which address the packet(s) appear to come from. If this +option is left out the IOS Device will source the packet automatically +based on routing and/or metrics. If this doesn't make sense to you +then just leave it out. + +The iosuser option allows you to specify a username that has ping +capability on the IOS Device. + +The iospass option allows you to specify the password for the username +specified with the option iosuser. + +=head1 IOS CONFIGURATION + +The IOS device should have a username/password configured, as well as +the ability to connect to the VTY(s). +eg: + + ! + username smokeping privilege 5 password 0 SmokepingPassword + ! + line vty 0 4 + login local + transport input telnet + ! + +=head1 NOTES + +=head2 Requirements + +This module requires the Net::Telnet module for perl. This is usually +included on most newer OSs which include perl. + +=head2 Debugging + +There is some VERY rudimentary debugging code built into this module (it's +based on the debugging code written into Net::Telnet). It will log +information into three files "TIPreturn", "TIPoutlog", and "TIPdump". +These files will be written out into your current working directory (CWD). +You can change the names of these files to something with more meaning to +you. + +=head2 Password authentication + +You should be advised that the authentication method of telnet uses +clear text transmissions...meaning that without proper network security +measures someone could sniff your username and password off the network. +I may attempt to incorporate SSH in a future version of this module, but +it is very doubtful. Right now SSH adds a LOT of processing overhead to +a router, and isn't incredibly easy to implement in perl. + +Having said this, don't be too scared of telnet. Remember, the +original IOSPing module used RSH, which is even more scary to use from +a security perspective. + +=head2 Ping packet size + +The FPing manpage has the following to say on the topic of ping packet +size: + +Number of bytes of ping data to send. The minimum size (normally 12) +allows room for the data that fping needs to do its work (sequence +number, timestamp). The reported received data size includes the IP +header (normally 20 bytes) and ICMP header (8 bytes), so the minimum +total size is 40 bytes. Default is 56, as in ping. Maximum is the +theoretical maximum IP datagram size (64K), though most systems limit +this to a smaller, system-dependent number. + +=head1 AUTHOR + +John A Jackson <geonjay@infoave.net> + +based HEAVILY on probes::IOSPing by + +Paul J Murphy <paul@murph.org> + +based on probes::FPing by + +Tobias Oetiker <tobi@oetiker.ch> + +=cut + +use strict; + +use base qw(probes::basefork); +use Net::Telnet (); +use Carp; + +sub new($$$) +{ + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(@_); + + # no need for this if we run as a cgi + unless ( $ENV{SERVER_SOFTWARE} ) { + croak "ERROR: IOSPing packetsize must be between 12 and 64000" + if $self->{properties}{packetsize} and + ( $self->{properties}{packetsize} < 12 or $self->{properties}{packetsize} > 64000 ); + + $self->{pingfactor} = 1000; # Gives us a good-guess default + print "### assuming you are using an IOS reporting in miliseconds\n"; + }; + + return $self; +} + +sub ProbeDesc($){ + my $self = shift; + my $bytes = $self->{properties}{packetsize} || 56; + return "InfoAve Cisco IOS - ICMP Echo Pings ($bytes Bytes)"; +} + +sub pingone ($$){ + my $self = shift; + my $target = shift; + my $source = $target->{vars}{source}; + my $dest = $target->{vars}{target}; + my $psource = $target->{vars}{psource} || ""; + my $port = 23; + my @output = (); + my $login = $target->{vars}{iosuser}; + my $pssword = $target->{vars}{iospass}; + my $bytes = $self->{properties}{packetsize} || 56; + my $pings = $self->pings($target); + + # do NOT call superclass ... the ping method MUST be overwriten + my %upd; + my @args = (); + + + my $telnet = new Net::Telnet; +# These are for debugging +# $telnet->errmode("TIPreturn"); +# $telnet->input_log("TIPinlog"); +# $telnet->dump_log("TIPdumplog"); + +#Open the Connection to the router +# open(OUTF,">outfile.IA") || die "Can't open OUTF: $!"; +# print OUTF "target => $dest\nsource => $source\nuser => $login\n"; + my $ok = $telnet->open(Host => $source, + Port => $port); +# print OUTF "Connection is a $ok\n"; + + #Authenticate + $telnet->waitfor('/(ogin|name|word):.*$/'); + $telnet->print("$login"); + $telnet->waitfor('/word:.*$/'); + $telnet->print("$pssword"); + #Do the work + $telnet->waitfor('/[\@\w\-\.]+[>#][ ]*$/'); + $telnet->print("terminal length 0"); + $telnet->waitfor('/[\@\w\-\.]+[>#][ ]*$/'); + $telnet->print("ping"); + $telnet->waitfor('/Protocol \[ip\]: $/'); + $telnet->print(""); + $telnet->waitfor('/Target IP address: $/'); + $telnet->print("$dest"); + $telnet->waitfor('/Repeat count \[5\]: $/'); + $telnet->print($pings); + $telnet->waitfor('/Datagram size \[100\]: $/'); + $telnet->print("$bytes"); + $telnet->waitfor('/Timeout in seconds \[2\]: $/'); + $telnet->print(""); + $telnet->waitfor('/Extended commands \[n\]: $/'); + $telnet->print("y"); + $telnet->waitfor('/Source address or interface: $/'); + $telnet->print("$psource"); + $telnet->waitfor('/Type of service \[0\]: $/'); + $telnet->print(""); + $telnet->waitfor('/Set DF bit in IP header\? \[no\]: $/'); + $telnet->print(""); + $telnet->waitfor('/Validate reply data\? \[no\]: $/'); + $telnet->print(""); + $telnet->waitfor('/Data pattern \[0xABCD\]: $/'); + $telnet->print(""); + $telnet->waitfor('/Loose, Strict, Record, Timestamp, Verbose\[none\]: $/'); + $telnet->print("v"); + $telnet->waitfor('/Loose, Strict, Record, Timestamp, Verbose\[V\]: $/'); + $telnet->print(""); + $telnet->waitfor('/Sweep range of sizes.+$/'); + + $telnet->prompt('/[\@\w\-\.]+[>#][ ]*$/'); + @output = $telnet->cmd("n"); + + #$telnet->waitfor('/[\@\w\-\.]+[>#][ ]*$/'); + $telnet->print("quit"); + $telnet->close; +# print OUTF "closed Telnet connection\n"; + + my @times = (); + while (@output) { + my $outputline = shift @output; + chomp($outputline); +# print OUTF "$outputline\n"; + $outputline =~ /^Reply to request \d+ \((\d+) ms\)/ && push(@times,$1); + #print OUTF "$outputline => $1\n"; + } + @times = map {sprintf "%.10e", $_ / $self->{pingfactor}} sort {$a <=> $b} @times; +# close(OUTF); + return @times; +} + +1; |