aksdb
/
restemplate
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Initial commit

This commit is contained in:
Andreas Schneider 2015-09-17 11:47:04 +02:00
commit c128b16996
48 changed files with 41459 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

674
LICENSE Normal file
View File

@ -0,0 +1,674 @@
GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The GNU General Public License is a free, copyleft license for
software and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users. We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors. 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
them 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 prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. 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.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software. For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so. This is fundamentally incompatible with the aim of
protecting users' freedom to change the software. The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable. Therefore, we
have designed this version of the GPL to prohibit the practice for those
products. If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary. To prevent this, the GPL assures that
patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
0. Definitions.
"This License" refers to version 3 of the GNU General Public License.
"Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy. The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force. You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright. Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section 10
makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.
4. Conveying Verbatim Copies.
You may convey 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;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:
a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
b) The work must carry prominent notices stating that it is
released under this License and any conditions added under section
7. This requirement modifies the requirement in section 4 to
"keep intact all notices".
c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:
a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the
Corresponding Source from a network server at no charge.
c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
e) Convey the object code using peer-to-peer transmission, provided
you inform other peers where the object code and Corresponding
Source of the work are being offered to the general public at no
charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling. In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage. For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product. A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source. The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed. Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:
a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
c) Prohibiting misrepresentation of the origin of that material, or
requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
d) Limiting the use for publicity purposes of names of licensors or
authors of the material; or
e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions of
it) with contractual assumptions of liability to the recipient, for
any liability that these contractual assumptions directly impose on
those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License. You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If 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 convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all. For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.
13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions of
the GNU 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 that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation. If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
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.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
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.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
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
state 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) <year> <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 3 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, see <http://www.gnu.org/licenses/>.
Also add information on how to contact you by electronic and paper mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
<program> Copyright (C) <year> <name of author>
This program 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, your program's commands
might be different; for a GUI interface, you would use an "about box".
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
<http://www.gnu.org/licenses/>.
The GNU 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 Lesser General
Public License instead of this License. But first, please read
<http://www.gnu.org/philosophy/why-not-lgpl.html>.

28
jtemplate/LICENSE Normal file
View File

@ -0,0 +1,28 @@
JTemplate plugin.
Copyright (C) 2013 Silvio Clecio - silvioprog@gmail.com
This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Library General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at your
option) any later version with the following modification:
As a special exception, the copyright holders of this library give you
permission to link this library with independent modules to produce an
executable, regardless of the license terms of these independent modules,and
to copy and distribute the resulting executable under terms of your choice,
provided that you also meet, for each linked independent module, the terms
and conditions of the license of that module. An independent module is a
module which is not derived from or based on this library. If you modify
this library, you may extend this exception to your version of the library,
but you are not obligated to do so. If you do not wish to do so, delete this
exception statement from your 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 Library General Public License
for more details.
You should have received a copy of the GNU Library General Public License
along with this library; if not, write to the Free Software Foundation,
Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

496
jtemplate/jtemplate.pas Normal file
View File

@ -0,0 +1,496 @@
(*
J-Template plugin.
Copyright (C) 2012-2014 Silvio Clecio.
Please see the LICENSE, README and AUTHORS files.
*)
unit JTemplate;
{$mode objfpc}{$H+}
interface
uses
SysUtils, StrUtils, Classes, FPJSON;
type
EJTemplate = class(Exception);
TJTemplateParserClass = class of TJTemplateParser;
TJTemplateStreamClass = class of TJTemplateStream;
TJTemplateLoadingFieldsEvent = procedure(Sender: TObject;
var AVar, AValue: string) of object;
TJTemplateReplacingEvent = procedure(Sender: TObject;
var AValue: string) of object;
{ TJTemplateParser }
TJTemplateParser = class
private
FContent: string;
FFields: TJSONObject;
FHtmlSupports: Boolean;
FOnLoadingFields: TJTemplateLoadingFieldsEvent;
FOnReplace: TNotifyEvent;
FOnReplacing: TJTemplateReplacingEvent;
FTagEscape: ShortString;
FTagPrefix: ShortString;
FTagSuffix: ShortString;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Replace(const ARecursive: Boolean = False); virtual;
property Content: string read FContent write FContent;
property Fields: TJSONObject read FFields write FFields;
property HtmlSupports: Boolean read FHtmlSupports write FHtmlSupports;
property TagPrefix: ShortString read FTagPrefix write FTagPrefix;
property TagSuffix: ShortString read FTagSuffix write FTagSuffix;
property TagEscape: ShortString read FTagEscape write FTagEscape;
property OnLoadingFields: TJTemplateLoadingFieldsEvent read FOnLoadingFields
write FOnLoadingFields;
property OnReplacing: TJTemplateReplacingEvent read FOnReplacing
write FOnReplacing;
property OnReplace: TNotifyEvent read FOnReplace write FOnReplace;
end;
{ TJTemplateStream }
TJTemplateStream = class
private
FParser: TJTemplateParser;
protected
function CreateParser: TJTemplateParser; virtual;
procedure FreeParser; virtual;
function GetParserClass: TJTemplateParserClass; virtual;
public
constructor Create; virtual;
destructor Destroy; override;
procedure LoadFromStream(AStream: TStream);
procedure LoadFromFile(const AFileName: TFileName);
procedure SaveToStream(AStream: TStream);
procedure SaveToFile(const AFileName: TFileName);
property Parser: TJTemplateParser read FParser write FParser;
end;
{ TJTemplate }
TJTemplate = class(TComponent)
private
FContent: TStrings;
FOnLoadingFields: TJTemplateLoadingFieldsEvent;
FOnReplace: TNotifyEvent;
FOnReplacing: TJTemplateReplacingEvent;
FStream: TJTemplateStream;
function GetContent: TStrings;
function GetFields: TJSONObject;
function GetHtmlSupports: Boolean;
function GetParser: TJTemplateParser;
function GetStream: TJTemplateStream;
function GetTagEscape: string;
function GetTagPrefix: string;
function GetTagSuffix: string;
procedure SetContent(AValue: TStrings);
procedure SetFields(AValue: TJSONObject);
procedure SetHtmlSupports(AValue: Boolean);
procedure SetParser(AValue: TJTemplateParser);
procedure SetStream(AValue: TJTemplateStream);
procedure SetTagEscape(AValue: string);
procedure SetTagPrefix(AValue: string);
procedure SetTagSuffix(AValue: string);
protected
procedure Loaded; override;
function CreateStream: TJTemplateStream; virtual;
procedure FreeStream; virtual;
function GetStreamClass: TJTemplateStreamClass;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Replace(const ARecursive: Boolean = False);
procedure LoadFromStream(AStream: TStream);
procedure LoadFromFile(const AFileName: TFileName);
procedure SaveToStream(AStream: TStream);
procedure SaveToFile(const AFileName: TFileName);
property Fields: TJSONObject read GetFields write SetFields;
property Parser: TJTemplateParser read GetParser write SetParser;
property Stream: TJTemplateStream read GetStream write SetStream;
published
property Content: TStrings read GetContent write SetContent;
property HtmlSupports: Boolean read GetHtmlSupports write SetHtmlSupports;
property TagPrefix: string read GetTagPrefix write SetTagPrefix;
property TagSuffix: string read GetTagSuffix write SetTagSuffix;
property TagEscape: string read GetTagEscape write SetTagEscape;
property OnLoadingFields: TJTemplateLoadingFieldsEvent read FOnLoadingFields
write FOnLoadingFields;
property OnReplacing: TJTemplateReplacingEvent read FOnReplacing
write FOnReplacing;
property OnReplace: TNotifyEvent read FOnReplace write FOnReplace;
end;
resourcestring
SNilParamError = '"%s" must not be nil.';
const
LatinCharsCount = 74;
LatinChars: array[0..LatinCharsCount] of string = (
'"', '<', '>', '^', '~', '£', '§', '°', '²', '³', 'µ', '·', '¼', '½', '¿',
'À', 'Á', 'Â', 'Ã', 'Ä', 'Å', 'Æ', 'Ç', 'È', 'É', 'Ê', 'Ë', 'Ì', 'Í', 'Î',
'Ï', 'Ñ', 'Ò', 'Ó', 'Ô', 'Õ', 'Ö', 'Ù', 'Ú', 'Û', 'Ü', 'Ý', 'ß', 'á', 'à',
'â', 'ã', 'ä', 'å', 'æ', 'ç', 'é', 'è', 'ê', 'ë', 'ì', 'í', 'î', 'ï', 'ñ',
'ò', 'ó', 'ô', 'õ', 'ö', '÷', 'ù', 'ú', 'û', 'ü', 'ý', 'ÿ', '&', '´', '`');
HtmlChars: array[0..LatinCharsCount] of string = (
'&quot;', '&lt;', '&gt;', '&circ;', '&tilde;', '&pound;', '&sect;', '&deg;',
'&sup2;', '&sup3;', '&micro;', '&middot;', '&frac14;', '&frac12;', '&iquest;',
'&Agrave;', '&Aacute;', '&Acirc;', '&Atilde;', '&Auml;', '&Aring;', '&AElig;',
'&Ccedil;', '&Egrave;', '&Eacute;', '&Ecirc;', '&Euml;', '&Igrave;', '&Iacute;',
'&Icirc;', '&Iuml;', '&Ntilde;', '&Ograve;', '&Oacute;', '&Ocirc;', '&Otilde;',
'&Ouml;', '&Ugrave;', '&Uacute;', '&Ucirc;', '&Uuml;', '&Yacute;', '&szlig;',
'&aacute;', '&agrave;', '&acirc;', '&atilde;', '&auml;', '&aring;', '&aelig;',
'&ccedil;', '&eacute;', '&egrave;', '&ecirc;', '&euml;', '&igrave;', '&iacute;',
'&icirc;', '&iuml;', '&ntilde;', '&ograve;', '&oacute;', '&ocirc;', '&otilde;',
'&ouml;', '&divide;', '&ugrave;', '&uacute;', '&ucirc;', '&uuml;', '&yacute;',
'&yuml;', '&amp;', '&acute;', '&grave;');
function StrToHtml(const S: string): string;
implementation
function StrToHtml(const S: string): string;
function _Found(const ABuf: PChar; const ALen: Integer): Integer; inline;
var
P: PString;
begin
for Result := Low(LatinChars) to High(LatinChars) do
begin
P := @LatinChars[Result];
if Length(P^) <= ALen then
// compare in blocks of 8(x64), 4, 2 and 1 byte
if CompareByte(P^[1], ABuf^, Length(P^)) = 0 then
Exit;
end;
Result := -1;
end;
var
I: Integer;
VResStr: string;
PComp, PLast: PChar;
begin
VResStr := '';
PComp := @S[1];
PLast := PComp + Length(S);
while PComp < PLast do
begin
I := _Found(PComp, PLast - PComp);
if I > -1 then
begin
VResStr := VResStr + HtmlChars[I];
Inc(PComp, Length(LatinChars[I]));
end
else
begin
// it can be optimized decreasing the concatenations
VResStr := VResStr + PComp^;
Inc(PComp);
end;
end;
Result := VResStr;
end;
{ TJTemplateParser }
constructor TJTemplateParser.Create;
begin
FFields := TJSONObject.Create;
FTagPrefix := '@';
FHtmlSupports := True;
end;
destructor TJTemplateParser.Destroy;
begin
FreeAndNil(FFields);
inherited Destroy;
end;
procedure TJTemplateParser.Replace(const ARecursive: Boolean);
var
VVar, VValue: string;
I, P, VTagLen, VEscapLen: Integer;
begin
VEscapLen := Length(FTagEscape);
for I := 0 to Pred(FFields.Count) do
begin
VVar := FTagPrefix + FFields.Names[I] + FTagSuffix;
if FHtmlSupports then
VValue := StrToHtml(FFields.Items[I].AsString)
else
VValue := FFields.Items[I].AsString;
if Assigned(FOnLoadingFields) then
FOnLoadingFields(Self, VVar, VValue);
P := 1;
VTagLen := Length(VVar);
repeat
P := PosEx(VVar, FContent, P);
if P < 1 then
Break;
if (VEscapLen <> 0) and // no TagEscape defined
(CompareChar(FContent[P - VEscapLen], FTagEscape[1], VEscapLen) = 0) then
begin
System.Delete(FContent, P - VEscapLen, VEscapLen);
Inc(P, VTagLen - VEscapLen);
end
else
begin
System.Delete(FContent, P, VTagLen);
if Assigned(FOnReplacing) then
FOnReplacing(Self, VValue);
Insert(VValue, FContent, P);
Inc(P, Length(VValue));
if not ARecursive then
Break;
end;
until False;
end;
if Assigned(FOnReplace) then
FOnReplace(Self);
end;
{ TJTemplateStream }
constructor TJTemplateStream.Create;
begin
inherited Create;
FParser := CreateParser;
end;
destructor TJTemplateStream.Destroy;
begin
FreeParser;
inherited Destroy;
end;
function TJTemplateStream.CreateParser: TJTemplateParser;
begin
Result := GetParserClass.Create;
end;
procedure TJTemplateStream.FreeParser;
begin
FreeAndNil(FParser);
end;
function TJTemplateStream.GetParserClass: TJTemplateParserClass;
begin
Result := TJTemplateParser;
end;
procedure TJTemplateStream.LoadFromStream(AStream: TStream);
begin
if not Assigned(AStream) then
raise EJTemplate.CreateFmt(SNilParamError, ['AStream']);
AStream.Seek(0, 0);
SetLength(FParser.FContent, AStream.Size);
AStream.Read(Pointer(FParser.FContent)^, Length(FParser.FContent));
end;
procedure TJTemplateStream.LoadFromFile(const AFileName: TFileName);
var
VFile: TFileStream;
begin
VFile := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
try
LoadFromStream(VFile);
finally
VFile.Free;
end;
end;
procedure TJTemplateStream.SaveToStream(AStream: TStream);
begin
if not Assigned(AStream) then
raise EJTemplate.CreateFmt(SNilParamError, ['AStream']);
AStream.Seek(0, 0);
AStream.Write(Pointer(FParser.FContent)^, Length(FParser.FContent));
end;
procedure TJTemplateStream.SaveToFile(const AFileName: TFileName);
var
VFile: TFileStream;
begin
VFile := TFileStream.Create(AFileName, fmCreate);
try
SaveToStream(VFile);
finally
VFile.Free;
end;
end;
{ TJTemplate }
constructor TJTemplate.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FStream := CreateStream;
FContent := TStringList.Create;
end;
destructor TJTemplate.Destroy;
begin
FContent.Free;
FreeStream;
inherited Destroy;
end;
function TJTemplate.CreateStream: TJTemplateStream;
begin
Result := GetStreamClass.Create;
end;
procedure TJTemplate.FreeStream;
begin
FreeAndNil(FStream);
end;
function TJTemplate.GetStreamClass: TJTemplateStreamClass;
begin
Result := TJTemplateStream;
end;
function TJTemplate.GetContent: TStrings;
begin
Result := FContent;
if Assigned(FContent) then
FContent.Text := FStream.FParser.FContent;
end;
function TJTemplate.GetFields: TJSONObject;
begin
Result := FStream.FParser.FFields;
end;
function TJTemplate.GetHtmlSupports: Boolean;
begin
Result := FStream.FParser.FHtmlSupports;
end;
function TJTemplate.GetParser: TJTemplateParser;
begin
Result := FStream.FParser;
end;
function TJTemplate.GetStream: TJTemplateStream;
begin
Result := FStream;
end;
function TJTemplate.GetTagEscape: string;
begin
Result := FStream.FParser.FTagEscape;
end;
function TJTemplate.GetTagPrefix: string;
begin
Result := FStream.FParser.FTagPrefix;
end;
function TJTemplate.GetTagSuffix: string;
begin
Result := FStream.FParser.FTagSuffix;
end;
procedure TJTemplate.SetContent(AValue: TStrings);
begin
if Assigned(AValue) then
begin
FContent.Assign(AValue);
FStream.FParser.FContent := AValue.Text;
end;
end;
procedure TJTemplate.SetFields(AValue: TJSONObject);
begin
FStream.FParser.FFields := AValue;
end;
procedure TJTemplate.SetHtmlSupports(AValue: Boolean);
begin
FStream.FParser.FHtmlSupports := AValue;
end;
procedure TJTemplate.SetParser(AValue: TJTemplateParser);
begin
FStream.FParser := AValue;
if Assigned(AValue) then
begin
AValue.OnLoadingFields := FOnLoadingFields;
AValue.OnReplacing := FOnReplacing;
AValue.OnReplace := FOnReplace;
end;
end;
procedure TJTemplate.SetStream(AValue: TJTemplateStream);
begin
FStream := AValue;
end;
procedure TJTemplate.SetTagEscape(AValue: string);
begin
FStream.FParser.FTagEscape := AValue;
end;
procedure TJTemplate.SetTagPrefix(AValue: string);
begin
FStream.FParser.FTagPrefix := AValue;
end;
procedure TJTemplate.SetTagSuffix(AValue: string);
begin
FStream.FParser.FTagSuffix := AValue;
end;
procedure TJTemplate.Loaded;
begin
inherited Loaded;
if Assigned(FContent) then
FStream.FParser.FContent := FContent.Text;
if Assigned(FStream) and Assigned(FStream.FParser) then
begin
if Assigned(FOnLoadingFields) then
FStream.FParser.OnLoadingFields := FOnLoadingFields;
if Assigned(FOnReplacing) then
FStream.FParser.OnReplacing := FOnReplacing;
if Assigned(FOnReplace) then
FStream.FParser.OnReplace := FOnReplace;
end;
end;
procedure TJTemplate.Replace(const ARecursive: Boolean);
begin
FStream.FParser.Replace(ARecursive);
end;
procedure TJTemplate.LoadFromStream(AStream: TStream);
begin
FStream.LoadFromStream(AStream);
end;
procedure TJTemplate.LoadFromFile(const AFileName: TFileName);
begin
FStream.LoadFromFile(AFileName);
end;
procedure TJTemplate.SaveToStream(AStream: TStream);
begin
FStream.SaveToStream(AStream);
end;
procedure TJTemplate.SaveToFile(const AFileName: TFileName);
begin
FStream.LoadFromFile(AFileName);
end;
end.

64
restemplate.lpi Normal file
View File

@ -0,0 +1,64 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="restemplate"/>
<UseAppBundle Value="False"/>
<ResourceType Value="res"/>
</General>
<i18n>
<EnableI18N LFM="False"/>
</i18n>
<VersionInfo>
<StringTable ProductVersion=""/>
</VersionInfo>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="restemplate.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<Target>
<Filename Value="restemplate"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<OtherUnitFiles Value="jtemplate;synapse"/>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

127
restemplate.lpr Normal file
View File

@ -0,0 +1,127 @@
{
This file is part of restemplate.
Copyright (C) 2015 Andreas Schneider
restemplate 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 3 of the License, or
(at your option) any later version.
sqlvision 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 restemplate. If not, see <http://www.gnu.org/licenses/>.
}
program restemplate;
uses
SysUtils, Classes, strutils, JTemplate, httpsend;
var
data: TextFile;
line: String;
parser: TJTemplateParser;
http: THTTPSend;
method: String;
content: TStringList;
commandMode: Boolean;
procedure CmdAskUser(AName: String);
var
value: String;
begin
Write(AName, ': ');
ReadLn(value);
parser.Fields.Add(AName, value);
end;
procedure CmdHeader(AHeader: String);
begin
parser.Content := AHeader;
parser.Replace;
http.Headers.Add(parser.Content);
end;
procedure CmdCall(AURL: String);
var
s: String;
begin
parser.Content := AURL;
parser.Replace;
writeln('Calling ', parser.Content);
if content.Count > 0 then
content.SaveToStream(http.Document);
if http.HTTPMethod(method, parser.Content) then
begin
writeln;
writeln('Status: ', http.ResultCode);
writeln;
writeln('Headers:');
for s in http.Headers do
writeln(' ', s);
writeln;
content.LoadFromStream(http.Document);
writeln(content.Text);
end else
writeln('FAILED !!!');
end;
function ProcessCommand(ALine: String): Boolean;
begin
Result := False;
if AnsiStartsStr('Ask ', ALine) then
begin
Result := True;
CmdAskUser(Copy(ALine, 5, Length(ALine)));
end else
if AnsiStartsStr('Header ', ALine) then
begin
Result := True;
CmdHeader(Copy(ALine, 8, Length(ALine)));
end else
if AnsiStartsStr('Method ', ALine) then
begin
Result := True;
method := Copy(ALine, 8, Length(ALine));
end else
if AnsiStartsStr('Call ', ALine) then
begin
Result := True;
CmdCall(Copy(ALine, 6, Length(ALine)));
end;
end;
begin
AssignFile(data, ParamStr(1));
Reset(data);
parser := TJTemplateParser.Create;
http := THTTPSend.Create;
content := TStringList.Create;
commandMode := True;
while not EOF(data) do
begin
ReadLn(data, line);
if commandMode and (line <> '') and not ProcessCommand(line) then
commandMode := False;
if not commandMode then
content.Add(line);
end;
parser.Free;
http.Free;
content.Free;
CloseFile(data);
end.

510
synapse/asn1util.pas Normal file
View File

@ -0,0 +1,510 @@
{==============================================================================|
| Project : Ararat Synapse | 001.004.004 |
|==============================================================================|
| Content: support for ASN.1 BER coding and decoding |
|==============================================================================|
| Copyright (c)1999-2003, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2003 |
| Portions created by Hernan Sanchez are Copyright (c) 2000. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Hernan Sanchez (hernan.sanchez@iname.com) |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(Utilities for handling ASN.1 BER encoding)
By this unit you can parse ASN.1 BER encoded data to elements or build back any
elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to
human readable form for easy debugging, too.
Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL,
ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER,
ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE
For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class.
}
{$Q-}
{$H+}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit asn1util;
interface
uses
SysUtils, Classes, synautil;
const
ASN1_BOOL = $01;
ASN1_INT = $02;
ASN1_OCTSTR = $04;
ASN1_NULL = $05;
ASN1_OBJID = $06;
ASN1_ENUM = $0a;
ASN1_SEQ = $30;
ASN1_SETOF = $31;
ASN1_IPADDR = $40;
ASN1_COUNTER = $41;
ASN1_GAUGE = $42;
ASN1_TIMETICKS = $43;
ASN1_OPAQUE = $44;
{:Encodes OID item to binary form.}
function ASNEncOIDItem(Value: Integer): AnsiString;
{:Decodes an OID item of the next element in the "Buffer" from the "Start"
position.}
function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer;
{:Encodes the length of ASN.1 element to binary.}
function ASNEncLen(Len: Integer): AnsiString;
{:Decodes length of next element in "Buffer" from the "Start" position.}
function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
{:Encodes a signed integer to ASN.1 binary}
function ASNEncInt(Value: Integer): AnsiString;
{:Encodes unsigned integer into ASN.1 binary}
function ASNEncUInt(Value: Integer): AnsiString;
{:Encodes ASN.1 object to binary form.}
function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
{:Beginning with the "Start" position, decode the ASN.1 item of the next element
in "Buffer". Type of item is stored in "ValueType."}
function ASNItem(var Start: Integer; const Buffer: AnsiString;
var ValueType: Integer): AnsiString;
{:Encodes an MIB OID string to binary form.}
function MibToId(Mib: String): AnsiString;
{:Decodes MIB OID from binary form to string form.}
function IdToMib(const Id: AnsiString): String;
{:Encodes an one number from MIB OID to binary form. (used internally from
@link(MibToId))}
function IntMibToStr(const Value: AnsiString): AnsiString;
{:Convert ASN.1 BER encoded buffer to human readable form for debugging.}
function ASNdump(const Value: AnsiString): AnsiString;
implementation
{==============================================================================}
function ASNEncOIDItem(Value: Integer): AnsiString;
var
x, xm: Integer;
b: Boolean;
begin
x := Value;
b := False;
Result := '';
repeat
xm := x mod 128;
x := x div 128;
if b then
xm := xm or $80;
if x > 0 then
b := True;
Result := AnsiChar(xm) + Result;
until x = 0;
end;
{==============================================================================}
function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer;
var
x: Integer;
b: Boolean;
begin
Result := 0;
repeat
Result := Result * 128;
x := Ord(Buffer[Start]);
Inc(Start);
b := x > $7F;
x := x and $7F;
Result := Result + x;
until not b;
end;
{==============================================================================}
function ASNEncLen(Len: Integer): AnsiString;
var
x, y: Integer;
begin
if Len < $80 then
Result := AnsiChar(Len)
else
begin
x := Len;
Result := '';
repeat
y := x mod 256;
x := x div 256;
Result := AnsiChar(y) + Result;
until x = 0;
y := Length(Result);
y := y or $80;
Result := AnsiChar(y) + Result;
end;
end;
{==============================================================================}
function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer;
var
x, n: Integer;
begin
x := Ord(Buffer[Start]);
Inc(Start);
if x < $80 then
Result := x
else
begin
Result := 0;
x := x and $7F;
for n := 1 to x do
begin
Result := Result * 256;
x := Ord(Buffer[Start]);
Inc(Start);
Result := Result + x;
end;
end;
end;
{==============================================================================}
function ASNEncInt(Value: Integer): AnsiString;
var
x, y: Cardinal;
neg: Boolean;
begin
neg := Value < 0;
x := Abs(Value);
if neg then
x := not (x - 1);
Result := '';
repeat
y := x mod 256;
x := x div 256;
Result := AnsiChar(y) + Result;
until x = 0;
if (not neg) and (Result[1] > #$7F) then
Result := #0 + Result;
end;
{==============================================================================}
function ASNEncUInt(Value: Integer): AnsiString;
var
x, y: Integer;
neg: Boolean;
begin
neg := Value < 0;
x := Value;
if neg then
x := x and $7FFFFFFF;
Result := '';
repeat
y := x mod 256;
x := x div 256;
Result := AnsiChar(y) + Result;
until x = 0;
if neg then
Result[1] := AnsiChar(Ord(Result[1]) or $80);
end;
{==============================================================================}
function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString;
begin
Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data;
end;
{==============================================================================}
function ASNItem(var Start: Integer; const Buffer: AnsiString;
var ValueType: Integer): AnsiString;
var
ASNType: Integer;
ASNSize: Integer;
y, n: Integer;
x: byte;
s: AnsiString;
c: AnsiChar;
neg: Boolean;
l: Integer;
begin
Result := '';
ValueType := ASN1_NULL;
l := Length(Buffer);
if l < (Start + 1) then
Exit;
ASNType := Ord(Buffer[Start]);
ValueType := ASNType;
Inc(Start);
ASNSize := ASNDecLen(Start, Buffer);
if (Start + ASNSize - 1) > l then
Exit;
if (ASNType and $20) > 0 then
// Result := '$' + IntToHex(ASNType, 2)
Result := Copy(Buffer, Start, ASNSize)
else
case ASNType of
ASN1_INT, ASN1_ENUM, ASN1_BOOL:
begin
y := 0;
neg := False;
for n := 1 to ASNSize do
begin
x := Ord(Buffer[Start]);
if (n = 1) and (x > $7F) then
neg := True;
if neg then
x := not x;
y := y * 256 + x;
Inc(Start);
end;
if neg then
y := -(y + 1);
Result := IntToStr(y);
end;
ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS:
begin
y := 0;
for n := 1 to ASNSize do
begin
y := y * 256 + Ord(Buffer[Start]);
Inc(Start);
end;
Result := IntToStr(y);
end;
ASN1_OCTSTR, ASN1_OPAQUE:
begin
for n := 1 to ASNSize do
begin
c := AnsiChar(Buffer[Start]);
Inc(Start);
s := s + c;
end;
Result := s;
end;
ASN1_OBJID:
begin
for n := 1 to ASNSize do
begin
c := AnsiChar(Buffer[Start]);
Inc(Start);
s := s + c;
end;
Result := IdToMib(s);
end;
ASN1_IPADDR:
begin
s := '';
for n := 1 to ASNSize do
begin
if (n <> 1) then
s := s + '.';
y := Ord(Buffer[Start]);
Inc(Start);
s := s + IntToStr(y);
end;
Result := s;
end;
ASN1_NULL:
begin
Result := '';
Start := Start + ASNSize;
end;
else // unknown
begin
for n := 1 to ASNSize do
begin
c := AnsiChar(Buffer[Start]);
Inc(Start);
s := s + c;
end;
Result := s;
end;
end;
end;
{==============================================================================}
function MibToId(Mib: String): AnsiString;
var
x: Integer;
function WalkInt(var s: String): Integer;
var
x: Integer;
t: AnsiString;
begin
x := Pos('.', s);
if x < 1 then
begin
t := s;
s := '';
end
else
begin
t := Copy(s, 1, x - 1);
s := Copy(s, x + 1, Length(s) - x);
end;
Result := StrToIntDef(t, 0);
end;
begin
Result := '';
x := WalkInt(Mib);
x := x * 40 + WalkInt(Mib);
Result := ASNEncOIDItem(x);
while Mib <> '' do
begin
x := WalkInt(Mib);
Result := Result + ASNEncOIDItem(x);
end;
end;
{==============================================================================}
function IdToMib(const Id: AnsiString): String;
var
x, y, n: Integer;
begin
Result := '';
n := 1;
while Length(Id) + 1 > n do
begin
x := ASNDecOIDItem(n, Id);
if (n - 1) = 1 then
begin
y := x div 40;
x := x mod 40;
Result := IntToStr(y);
end;
Result := Result + '.' + IntToStr(x);
end;
end;
{==============================================================================}
function IntMibToStr(const Value: AnsiString): AnsiString;
var
n, y: Integer;
begin
y := 0;
for n := 1 to Length(Value) - 1 do
y := y * 256 + Ord(Value[n]);
Result := IntToStr(y);
end;
{==============================================================================}
function ASNdump(const Value: AnsiString): AnsiString;
var
i, at, x, n: integer;
s, indent: AnsiString;
il: TStringList;
begin
il := TStringList.Create;
try
Result := '';
i := 1;
indent := '';
while i < Length(Value) do
begin
for n := il.Count - 1 downto 0 do
begin
x := StrToIntDef(il[n], 0);
if x <= i then
begin
il.Delete(n);
Delete(indent, 1, 2);
end;
end;
s := ASNItem(i, Value, at);
Result := Result + indent + '$' + IntToHex(at, 2);
if (at and $20) > 0 then
begin
x := Length(s);
Result := Result + ' constructed: length ' + IntToStr(x);
indent := indent + ' ';
il.Add(IntToStr(x + i - 1));
end
else
begin
case at of
ASN1_BOOL:
Result := Result + ' BOOL: ';
ASN1_INT:
Result := Result + ' INT: ';
ASN1_ENUM:
Result := Result + ' ENUM: ';
ASN1_COUNTER:
Result := Result + ' COUNTER: ';
ASN1_GAUGE:
Result := Result + ' GAUGE: ';
ASN1_TIMETICKS:
Result := Result + ' TIMETICKS: ';
ASN1_OCTSTR:
Result := Result + ' OCTSTR: ';
ASN1_OPAQUE:
Result := Result + ' OPAQUE: ';
ASN1_OBJID:
Result := Result + ' OBJID: ';
ASN1_IPADDR:
Result := Result + ' IPADDR: ';
ASN1_NULL:
Result := Result + ' NULL: ';
else // other
Result := Result + ' unknown: ';
end;
if IsBinaryString(s) then
s := DumpExStr(s);
Result := Result + s;
end;
Result := Result + #$0d + #$0a;
end;
finally
il.Free;
end;
end;
{==============================================================================}
end.

4333
synapse/blcksock.pas Normal file
View File

File diff suppressed because it is too large Load Diff

277
synapse/clamsend.pas Normal file
View File

@ -0,0 +1,277 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: ClamAV-daemon client |
|==============================================================================|
| Copyright (c)2005-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract( ClamAV-daemon client)
This unit is capable to do antivirus scan of your data by TCP channel to ClamD
daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net)
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit clamsend;
interface
uses
SysUtils, Classes,
synsock, blcksock, synautil;
const
cClamProtocol = '3310';
type
{:@abstract(Implementation of ClamAV-daemon client protocol)
By this class you can scan any your data by ClamAV opensource antivirus.
This class can connect to ClamD by TCP channel, send your data to ClamD
and read result.}
TClamSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FDSock: TTCPBlockSocket;
FSession: boolean;
function Login: boolean; virtual;
function Logout: Boolean; virtual;
function OpenStream: Boolean; virtual;
public
constructor Create;
destructor Destroy; override;
{:Call any command to ClamD. Used internally by other methods.}
function DoCommand(const Value: AnsiString): AnsiString; virtual;
{:Return ClamAV version and version of loaded databases.}
function GetVersion: AnsiString; virtual;
{:Scan content of TStrings.}
function ScanStrings(const Value: TStrings): AnsiString; virtual;
{:Scan content of TStream.}
function ScanStream(const Value: TStream): AnsiString; virtual;
{:Scan content of TStrings by new 0.95 API.}
function ScanStrings2(const Value: TStrings): AnsiString; virtual;
{:Scan content of TStream by new 0.95 API.}
function ScanStream2(const Value: TStream): AnsiString; virtual;
published
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.}
property DSock: TTCPBlockSocket read FDSock;
{:Can turn-on session mode of communication with ClamD. Default is @false,
because ClamAV developers design their TCP code very badly and session mode
is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs
and this mode will be possible in future.}
property Session: boolean read FSession write FSession;
end;
implementation
constructor TClamSend.Create;
begin
inherited Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FDSock := TTCPBlockSocket.Create;
FDSock.Owner := self;
FTimeout := 60000;
FTargetPort := cClamProtocol;
FSession := false;
end;
destructor TClamSend.Destroy;
begin
Logout;
FDSock.Free;
FSock.Free;
inherited Destroy;
end;
function TClamSend.DoCommand(const Value: AnsiString): AnsiString;
begin
Result := '';
if not FSession then
FSock.CloseSocket
else
FSock.SendString(Value + LF);
if not FSession or (FSock.LastError <> 0) then
begin
if Login then
FSock.SendString(Value + LF)
else
Exit;
end;
Result := FSock.RecvTerminated(FTimeout, LF);
end;
function TClamSend.Login: boolean;
begin
Result := False;
Sock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError <> 0 then
Exit;
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError <> 0 then
Exit;
if FSession then
FSock.SendString('SESSION' + LF);
Result := FSock.LastError = 0;
end;
function TClamSend.Logout: Boolean;
begin
FSock.SendString('END' + LF);
Result := FSock.LastError = 0;
FSock.CloseSocket;
end;
function TClamSend.GetVersion: AnsiString;
begin
Result := DoCommand('nVERSION');
end;
function TClamSend.OpenStream: Boolean;
var
S: AnsiString;
begin
Result := False;
s := DoCommand('nSTREAM');
if (s <> '') and (Copy(s, 1, 4) = 'PORT') then
begin
s := SeparateRight(s, ' ');
FDSock.CloseSocket;
FDSock.Bind(FIPInterface, cAnyPort);
if FDSock.LastError <> 0 then
Exit;
FDSock.Connect(FTargetHost, s);
if FDSock.LastError <> 0 then
Exit;
Result := True;
end;
end;
function TClamSend.ScanStrings(const Value: TStrings): AnsiString;
begin
Result := '';
if OpenStream then
begin
DSock.SendString(Value.Text);
DSock.CloseSocket;
Result := FSock.RecvTerminated(FTimeout, LF);
end;
end;
function TClamSend.ScanStream(const Value: TStream): AnsiString;
begin
Result := '';
if OpenStream then
begin
DSock.SendStreamRaw(Value);
DSock.CloseSocket;
Result := FSock.RecvTerminated(FTimeout, LF);
end;
end;
function TClamSend.ScanStrings2(const Value: TStrings): AnsiString;
var
i: integer;
s: AnsiString;
begin
Result := '';
if not FSession then
FSock.CloseSocket
else
FSock.sendstring('nINSTREAM' + LF);
if not FSession or (FSock.LastError <> 0) then
begin
if Login then
FSock.sendstring('nINSTREAM' + LF)
else
Exit;
end;
s := Value.text;
i := length(s);
FSock.SendString(CodeLongint(i) + s + #0#0#0#0);
Result := FSock.RecvTerminated(FTimeout, LF);
end;
function TClamSend.ScanStream2(const Value: TStream): AnsiString;
var
i: integer;
begin
Result := '';
if not FSession then
FSock.CloseSocket
else
FSock.sendstring('nINSTREAM' + LF);
if not FSession or (FSock.LastError <> 0) then
begin
if Login then
FSock.sendstring('nINSTREAM' + LF)
else
Exit;
end;
i := value.Size;
FSock.SendString(CodeLongint(i));
FSock.SendStreamRaw(Value);
FSock.SendString(#0#0#0#0);
Result := FSock.RecvTerminated(FTimeout, LF);
end;
end.

603
synapse/dnssend.pas Normal file
View File

@ -0,0 +1,603 @@
{==============================================================================|
| Project : Ararat Synapse | 002.007.006 |
|==============================================================================|
| Content: DNS client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(DNS client by UDP or TCP)
Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone
transfers too!
Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit dnssend;
interface
uses
SysUtils, Classes,
blcksock, synautil, synaip, synsock;
const
cDnsProtocol = '53';
QTYPE_A = 1;
QTYPE_NS = 2;
QTYPE_MD = 3;
QTYPE_MF = 4;
QTYPE_CNAME = 5;
QTYPE_SOA = 6;
QTYPE_MB = 7;
QTYPE_MG = 8;
QTYPE_MR = 9;
QTYPE_NULL = 10;
QTYPE_WKS = 11; //
QTYPE_PTR = 12;
QTYPE_HINFO = 13;
QTYPE_MINFO = 14;
QTYPE_MX = 15;
QTYPE_TXT = 16;
QTYPE_RP = 17;
QTYPE_AFSDB = 18;
QTYPE_X25 = 19;
QTYPE_ISDN = 20;
QTYPE_RT = 21;
QTYPE_NSAP = 22;
QTYPE_NSAPPTR = 23;
QTYPE_SIG = 24; // RFC-2065
QTYPE_KEY = 25; // RFC-2065
QTYPE_PX = 26;
QTYPE_GPOS = 27;
QTYPE_AAAA = 28;
QTYPE_LOC = 29; // RFC-1876
QTYPE_NXT = 30; // RFC-2065
QTYPE_SRV = 33;
QTYPE_NAPTR = 35; // RFC-2168
QTYPE_KX = 36;
QTYPE_SPF = 99;
QTYPE_AXFR = 252;
QTYPE_MAILB = 253; //
QTYPE_MAILA = 254; //
QTYPE_ALL = 255;
type
{:@abstract(Implementation of DNS protocol by UDP or TCP protocol.)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TDNSSend = class(TSynaClient)
private
FID: Word;
FRCode: Integer;
FBuffer: AnsiString;
FSock: TUDPBlockSocket;
FTCPSock: TTCPBlockSocket;
FUseTCP: Boolean;
FAnswerInfo: TStringList;
FNameserverInfo: TStringList;
FAdditionalInfo: TStringList;
FAuthoritative: Boolean;
FTruncated: Boolean;
function CompressName(const Value: AnsiString): AnsiString;
function CodeHeader: AnsiString;
function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
function DecodeLabels(var From: Integer): AnsiString;
function DecodeString(var From: Integer): AnsiString;
function DecodeResource(var i: Integer; const Info: TStringList;
QType: Integer): AnsiString;
function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
function DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
QType: Integer):boolean;
public
constructor Create;
destructor Destroy; override;
{:Query a DNSHost for QType resources correspond to a name. Supported QType
values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA,
Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO,
Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25,
Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS,
Qtype_KX.
Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode!
"Name" is domain name or host name for queried resource. If "name" is
IP address, automatically convert to reverse domain form (.in-addr.arpa).
If result is @true, Reply contains resource records. One record on one line.
If Resource record have multiple fields, they are stored on line divided by
comma. (example: MX record contains value 'rs.cesnet.cz' with preference
number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address
in resource are converted to string form.}
function DNSQuery(Name: AnsiString; QType: Integer;
const Reply: TStrings): Boolean;
published
{:Socket object used for UDP operation. Good for seting OnStatus hook, etc.}
property Sock: TUDPBlockSocket read FSock;
{:Socket object used for TCP operation. Good for seting OnStatus hook, etc.}
property TCPSock: TTCPBlockSocket read FTCPSock;
{:if @true, then is used TCP protocol instead UDP. It is needed for zone
transfers, etc.}
property UseTCP: Boolean read FUseTCP Write FUseTCP;
{:After DNS operation contains ResultCode of DNS operation.
Values are: 0-no error, 1-format error, 2-server failure, 3-name error,
4-not implemented, 5-refused.}
property RCode: Integer read FRCode;
{:@True, if answer is authoritative.}
property Authoritative: Boolean read FAuthoritative;
{:@True, if answer is truncated to 512 bytes.}
property Truncated: Boolean read FTRuncated;
{:Detailed informations from name server reply. One record per line. Record
have comma delimited entries with type number, TTL and data filelds.
This information contains detailed information about query reply.}
property AnswerInfo: TStringList read FAnswerInfo;
{:Detailed informations from name server reply. One record per line. Record
have comma delimited entries with type number, TTL and data filelds.
This information contains detailed information about nameserver.}
property NameserverInfo: TStringList read FNameserverInfo;
{:Detailed informations from name server reply. One record per line. Record
have comma delimited entries with type number, TTL and data filelds.
This information contains detailed additional information.}
property AdditionalInfo: TStringList read FAdditionalInfo;
end;
{:A very useful function, and example of it's use is found in the TDNSSend object.
This function is used to get mail servers for a domain and sort them by
preference numbers. "Servers" contains only the domain names of the mail
servers in the right order (without preference number!). The first domain name
will always be the highest preferenced mail server. Returns boolean @TRUE if
all went well.}
function GetMailServers(const DNSHost, Domain: AnsiString;
const Servers: TStrings): Boolean;
implementation
constructor TDNSSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTCPSock := TTCPBlockSocket.Create;
FTCPSock.Owner := self;
FUseTCP := False;
FTimeout := 10000;
FTargetPort := cDnsProtocol;
FAnswerInfo := TStringList.Create;
FNameserverInfo := TStringList.Create;
FAdditionalInfo := TStringList.Create;
Randomize;
end;
destructor TDNSSend.Destroy;
begin
FAnswerInfo.Free;
FNameserverInfo.Free;
FAdditionalInfo.Free;
FTCPSock.Free;
FSock.Free;
inherited Destroy;
end;
function TDNSSend.CompressName(const Value: AnsiString): AnsiString;
var
n: Integer;
s: AnsiString;
begin
Result := '';
if Value = '' then
Result := #0
else
begin
s := '';
for n := 1 to Length(Value) do
if Value[n] = '.' then
begin
Result := Result + AnsiChar(Length(s)) + s;
s := '';
end
else
s := s + Value[n];
if s <> '' then
Result := Result + AnsiChar(Length(s)) + s;
Result := Result + #0;
end;
end;
function TDNSSend.CodeHeader: AnsiString;
begin
FID := Random(32767);
Result := CodeInt(FID); // ID
Result := Result + CodeInt($0100); // flags
Result := Result + CodeInt(1); // QDCount
Result := Result + CodeInt(0); // ANCount
Result := Result + CodeInt(0); // NSCount
Result := Result + CodeInt(0); // ARCount
end;
function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString;
begin
Result := CompressName(Name);
Result := Result + CodeInt(QType);
Result := Result + CodeInt(1); // Type INTERNET
end;
function TDNSSend.DecodeString(var From: Integer): AnsiString;
var
Len: integer;
begin
Len := Ord(FBuffer[From]);
Inc(From);
Result := Copy(FBuffer, From, Len);
Inc(From, Len);
end;
function TDNSSend.DecodeLabels(var From: Integer): AnsiString;
var
l, f: Integer;
begin
Result := '';
while True do
begin
if From >= Length(FBuffer) then
Break;
l := Ord(FBuffer[From]);
Inc(From);
if l = 0 then
Break;
if Result <> '' then
Result := Result + '.';
if (l and $C0) = $C0 then
begin
f := l and $3F;
f := f * 256 + Ord(FBuffer[From]) + 1;
Inc(From);
Result := Result + DecodeLabels(f);
Break;
end
else
begin
Result := Result + Copy(FBuffer, From, l);
Inc(From, l);
end;
end;
end;
function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList;
QType: Integer): AnsiString;
var
Rname: AnsiString;
RType, Len, j, x, y, z, n: Integer;
R: AnsiString;
t1, t2, ttl: integer;
ip6: TIp6bytes;
begin
Result := '';
R := '';
Rname := DecodeLabels(i);
RType := DecodeInt(FBuffer, i);
Inc(i, 4);
t1 := DecodeInt(FBuffer, i);
Inc(i, 2);
t2 := DecodeInt(FBuffer, i);
Inc(i, 2);
ttl := t1 * 65536 + t2;
Len := DecodeInt(FBuffer, i);
Inc(i, 2); // i point to begin of data
j := i;
i := i + len; // i point to next record
if Length(FBuffer) >= (i - 1) then
case RType of
QTYPE_A:
begin
R := IntToStr(Ord(FBuffer[j]));
Inc(j);
R := R + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j);
R := R + '.' + IntToStr(Ord(FBuffer[j]));
Inc(j);
R := R + '.' + IntToStr(Ord(FBuffer[j]));
end;
QTYPE_AAAA:
begin
for n := 0 to 15 do
ip6[n] := ord(FBuffer[j + n]);
R := IP6ToStr(ip6);
end;
QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB,
QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP,
QTYPE_NSAPPTR:
R := DecodeLabels(j);
QTYPE_SOA:
begin
R := DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
for n := 1 to 5 do
begin
x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2);
Inc(j, 4);
R := R + ',' + IntToStr(x);
end;
end;
QTYPE_NULL:
begin
end;
QTYPE_WKS:
begin
end;
QTYPE_HINFO:
begin
R := DecodeString(j);
R := R + ',' + DecodeString(j);
end;
QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN:
begin
R := DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX:
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
R := IntToStr(x);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_TXT, QTYPE_SPF:
begin
R := '';
while j < i do
R := R + DecodeString(j);
end;
QTYPE_GPOS:
begin
R := DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_PX:
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
R := IntToStr(x);
R := R + ',' + DecodeLabels(j);
R := R + ',' + DecodeLabels(j);
end;
QTYPE_SRV:
// Author: Dan <ml@mutox.org>
begin
x := DecodeInt(FBuffer, j);
Inc(j, 2);
y := DecodeInt(FBuffer, j);
Inc(j, 2);
z := DecodeInt(FBuffer, j);
Inc(j, 2);
R := IntToStr(x); // Priority
R := R + ',' + IntToStr(y); // Weight
R := R + ',' + IntToStr(z); // Port
R := R + ',' + DecodeLabels(j); // Server DNS Name
end;
end;
if R <> '' then
Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R);
if QType = RType then
Result := R;
end;
function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString;
var
l: integer;
begin
Result := '';
l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout);
if l > 0 then
Result := WorkSock.RecvBufferStr(l, FTimeout);
end;
function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings;
QType: Integer):boolean;
var
n, i: Integer;
flag, qdcount, ancount, nscount, arcount: Integer;
s: AnsiString;
begin
Result := False;
Reply.Clear;
FAnswerInfo.Clear;
FNameserverInfo.Clear;
FAdditionalInfo.Clear;
FAuthoritative := False;
if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then
begin
Result := True;
flag := DecodeInt(Buf, 3);
FRCode := Flag and $000F;
FAuthoritative := (Flag and $0400) > 0;
FTruncated := (Flag and $0200) > 0;
if FRCode = 0 then
begin
qdcount := DecodeInt(Buf, 5);
ancount := DecodeInt(Buf, 7);
nscount := DecodeInt(Buf, 9);
arcount := DecodeInt(Buf, 11);
i := 13; //begin of body
if (qdcount > 0) and (Length(Buf) > i) then //skip questions
for n := 1 to qdcount do
begin
while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do
Inc(i);
Inc(i, 5);
end;
if (ancount > 0) and (Length(Buf) > i) then // decode reply
for n := 1 to ancount do
begin
s := DecodeResource(i, FAnswerInfo, QType);
if s <> '' then
Reply.Add(s);
end;
if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info
for n := 1 to nscount do
DecodeResource(i, FNameserverInfo, QType);
if (arcount > 0) and (Length(Buf) > i) then // decode additional info
for n := 1 to arcount do
DecodeResource(i, FAdditionalInfo, QType);
end;
end;
end;
function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer;
const Reply: TStrings): Boolean;
var
WorkSock: TBlockSocket;
t: TStringList;
b: boolean;
begin
Result := False;
if IsIP(Name) then
Name := ReverseIP(Name) + '.in-addr.arpa';
if IsIP6(Name) then
Name := ReverseIP6(Name) + '.ip6.arpa';
FBuffer := CodeHeader + CodeQuery(Name, QType);
if FUseTCP then
WorkSock := FTCPSock
else
WorkSock := FSock;
WorkSock.Bind(FIPInterface, cAnyPort);
WorkSock.Connect(FTargetHost, FTargetPort);
if FUseTCP then
FBuffer := Codeint(length(FBuffer)) + FBuffer;
WorkSock.SendString(FBuffer);
if FUseTCP then
FBuffer := RecvTCPResponse(WorkSock)
else
FBuffer := WorkSock.RecvPacket(FTimeout);
if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer
begin
t := TStringList.Create;
try
repeat
b := DecodeResponse(FBuffer, Reply, QType);
if (t.Count > 1) and (AnswerInfo.Count > 0) then //find end of transfer
b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]);
if b then
begin
t.AddStrings(AnswerInfo);
FBuffer := RecvTCPResponse(WorkSock);
if FBuffer = '' then
Break;
if WorkSock.LastError <> 0 then
Break;
end;
until not b;
Reply.Assign(t);
Result := True;
finally
t.free;
end;
end
else //normal query
if WorkSock.LastError = 0 then
Result := DecodeResponse(FBuffer, Reply, QType);
end;
{==============================================================================}
function GetMailServers(const DNSHost, Domain: AnsiString;
const Servers: TStrings): Boolean;
var
DNS: TDNSSend;
t: TStringList;
n, m, x: Integer;
begin
Result := False;
Servers.Clear;
t := TStringList.Create;
DNS := TDNSSend.Create;
try
DNS.TargetHost := DNSHost;
if DNS.DNSQuery(Domain, QType_MX, t) then
begin
{ normalize preference number to 5 digits }
for n := 0 to t.Count - 1 do
begin
x := Pos(',', t[n]);
if x > 0 then
for m := 1 to 6 - x do
t[n] := '0' + t[n];
end;
{ sort server list }
t.Sorted := True;
{ result is sorted list without preference numbers }
for n := 0 to t.Count - 1 do
begin
x := Pos(',', t[n]);
Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x));
end;
Result := True;
end;
finally
DNS.Free;
t.Free;
end;
end;
end.

1964
synapse/ftpsend.pas Normal file
View File

File diff suppressed because it is too large Load Diff

403
synapse/ftptsend.pas Normal file
View File

@ -0,0 +1,403 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: Trivial FTP (TFTP) client and server |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{: @abstract(TFTP client and server protocol)
Used RFC: RFC-1350
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ftptsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cTFTPProtocol = '69';
cTFTP_RRQ = word(1);
cTFTP_WRQ = word(2);
cTFTP_DTA = word(3);
cTFTP_ACK = word(4);
cTFTP_ERR = word(5);
type
{:@abstract(Implementation of TFTP client and server)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TTFTPSend = class(TSynaClient)
private
FSock: TUDPBlockSocket;
FErrorCode: integer;
FErrorString: string;
FData: TMemoryStream;
FRequestIP: string;
FRequestPort: string;
function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
function RecvPacket(Serial: word; var Value: string): Boolean;
public
constructor Create;
destructor Destroy; override;
{:Upload @link(data) as file to TFTP server.}
function SendFile(const Filename: string): Boolean;
{:Download file from TFTP server to @link(data).}
function RecvFile(const Filename: string): Boolean;
{:Acts as TFTP server and wait for client request. When some request
incoming within Timeout, result is @true and parametres is filled with
information from request. You must handle this request, validate it, and
call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply
to TFTP Client.}
function WaitForRequest(var Req: word; var filename: string): Boolean;
{:send error to TFTP client, when you acts as TFTP server.}
procedure ReplyError(Error: word; Description: string);
{:Accept uploaded file from TFTP client to @link(data), when you acts as
TFTP server.}
function ReplyRecv: Boolean;
{:Accept download request file from TFTP client and send content of
@link(data), when you acts as TFTP server.}
function ReplySend: Boolean;
published
{:Code of TFTP error.}
property ErrorCode: integer read FErrorCode;
{:Human readable decription of TFTP error. (if is sended by remote side)}
property ErrorString: string read FErrorString;
{:MemoryStream with datas for sending or receiving}
property Data: TMemoryStream read FData;
{:Address of TFTP remote side.}
property RequestIP: string read FRequestIP write FRequestIP;
{:Port of TFTP remote side.}
property RequestPort: string read FRequestPort write FRequestPort;
end;
implementation
constructor TTFTPSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTargetPort := cTFTPProtocol;
FData := TMemoryStream.Create;
FErrorCode := 0;
FErrorString := '';
end;
destructor TTFTPSend.Destroy;
begin
FSock.Free;
FData.Free;
inherited Destroy;
end;
function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean;
var
s, sh: string;
begin
FErrorCode := 0;
FErrorString := '';
Result := false;
if Cmd <> 2 then
s := CodeInt(Cmd) + CodeInt(Serial) + Value
else
s := CodeInt(Cmd) + Value;
FSock.SendString(s);
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
if length(s) >= 4 then
begin
sh := CodeInt(4) + CodeInt(Serial);
if Pos(sh, s) = 1 then
Result := True
else
if s[1] = #5 then
begin
FErrorCode := DecodeInt(s, 3);
Delete(s, 1, 4);
FErrorString := SeparateLeft(s, #0);
end;
end;
end;
function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean;
var
s: string;
ser: word;
begin
FErrorCode := 0;
FErrorString := '';
Result := False;
Value := '';
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
if length(s) >= 4 then
if DecodeInt(s, 1) = 3 then
begin
ser := DecodeInt(s, 3);
if ser = Serial then
begin
Delete(s, 1, 4);
Value := s;
S := CodeInt(4) + CodeInt(ser);
FSock.SendString(s);
Result := FSock.LastError = 0;
end
else
begin
S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0;
FSock.SendString(s);
end;
end;
if DecodeInt(s, 1) = 5 then
begin
FErrorCode := DecodeInt(s, 3);
Delete(s, 1, 4);
FErrorString := SeparateLeft(s, #0);
end;
end;
function TTFTPSend.SendFile(const Filename: string): Boolean;
var
s: string;
ser: word;
n, n1, n2: integer;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FTargetHost, FTargetPort);
try
if FSock.LastError = 0 then
begin
s := Filename + #0 + 'octet' + #0;
if not Sendpacket(2, 0, s) then
Exit;
ser := 1;
FData.Position := 0;
n1 := FData.Size div 512;
n2 := FData.Size mod 512;
for n := 1 to n1 do
begin
s := ReadStrFromStream(FData, 512);
// SetLength(s, 512);
// FData.Read(pointer(s)^, 512);
if not Sendpacket(3, ser, s) then
Exit;
inc(ser);
end;
s := ReadStrFromStream(FData, n2);
// SetLength(s, n2);
// FData.Read(pointer(s)^, n2);
if not Sendpacket(3, ser, s) then
Exit;
Result := True;
end;
finally
FSock.CloseSocket;
end;
end;
function TTFTPSend.RecvFile(const Filename: string): Boolean;
var
s: string;
ser: word;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FTargetHost, FTargetPort);
try
if FSock.LastError = 0 then
begin
s := CodeInt(1) + Filename + #0 + 'octet' + #0;
FSock.SendString(s);
if FSock.LastError <> 0 then
Exit;
FData.Clear;
ser := 1;
repeat
if not RecvPacket(ser, s) then
Exit;
inc(ser);
WriteStrToStream(FData, s);
// FData.Write(pointer(s)^, length(s));
until length(s) <> 512;
FData.Position := 0;
Result := true;
end;
finally
FSock.CloseSocket;
end;
end;
function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean;
var
s: string;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Bind('0.0.0.0', FTargetPort);
if FSock.LastError = 0 then
begin
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
if Length(s) >= 4 then
begin
FRequestIP := FSock.GetRemoteSinIP;
FRequestPort := IntToStr(FSock.GetRemoteSinPort);
Req := DecodeInt(s, 1);
delete(s, 1, 2);
filename := Trim(SeparateLeft(s, #0));
s := SeparateRight(s, #0);
s := SeparateLeft(s, #0);
Result := lowercase(trim(s)) = 'octet';
end;
end;
end;
procedure TTFTPSend.ReplyError(Error: word; Description: string);
var
s: string;
begin
FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort);
s := CodeInt(5) + CodeInt(Error) + Description + #0;
FSock.SendString(s);
FSock.CloseSocket;
end;
function TTFTPSend.ReplyRecv: Boolean;
var
s: string;
ser: integer;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort);
try
s := CodeInt(4) + CodeInt(0);
FSock.SendString(s);
FData.Clear;
ser := 1;
repeat
if not RecvPacket(ser, s) then
Exit;
inc(ser);
WriteStrToStream(FData, s);
// FData.Write(pointer(s)^, length(s));
until length(s) <> 512;
FData.Position := 0;
Result := true;
finally
FSock.CloseSocket;
end;
end;
function TTFTPSend.ReplySend: Boolean;
var
s: string;
ser: word;
n, n1, n2: integer;
begin
Result := False;
FErrorCode := 0;
FErrorString := '';
FSock.CloseSocket;
FSock.Connect(FRequestIP, FRequestPort);
try
ser := 1;
FData.Position := 0;
n1 := FData.Size div 512;
n2 := FData.Size mod 512;
for n := 1 to n1 do
begin
s := ReadStrFromStream(FData, 512);
// SetLength(s, 512);
// FData.Read(pointer(s)^, 512);
if not Sendpacket(3, ser, s) then
Exit;
inc(ser);
end;
s := ReadStrFromStream(FData, n2);
// SetLength(s, n2);
// FData.Read(pointer(s)^, n2);
if not Sendpacket(3, ser, s) then
Exit;
Result := True;
finally
FSock.CloseSocket;
end;
end;
{==============================================================================}
end.

845
synapse/httpsend.pas Normal file
View File

@ -0,0 +1,845 @@
{==============================================================================|
| Project : Ararat Synapse | 003.012.006 |
|==============================================================================|
| Content: HTTP client |
|==============================================================================|
| Copyright (c)1999-2011, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2011. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(HTTP protocol client)
Used RFC: RFC-1867, RFC-1947, RFC-2388, RFC-2616
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit httpsend;
interface
uses
SysUtils, Classes,
blcksock, synautil, synaip, synacode, synsock;
const
cHttpProtocol = '80';
type
{:These encoding types are used internally by the THTTPSend object to identify
the transfer data types.}
TTransferEncoding = (TE_UNKNOWN, TE_IDENTITY, TE_CHUNKED);
{:abstract(Implementation of HTTP protocol.)}
THTTPSend = class(TSynaClient)
protected
FSock: TTCPBlockSocket;
FTransferEncoding: TTransferEncoding;
FAliveHost: string;
FAlivePort: string;
FHeaders: TStringList;
FDocument: TMemoryStream;
FMimeType: string;
FProtocol: string;
FKeepAlive: Boolean;
FKeepAliveTimeout: integer;
FStatus100: Boolean;
FProxyHost: string;
FProxyPort: string;
FProxyUser: string;
FProxyPass: string;
FResultCode: Integer;
FResultString: string;
FUserAgent: string;
FCookies: TStringList;
FDownloadSize: integer;
FUploadSize: integer;
FRangeStart: integer;
FRangeEnd: integer;
FAddPortNumberToHost: Boolean;
function ReadUnknown: Boolean;
function ReadIdentity(Size: Integer): Boolean;
function ReadChunked: Boolean;
procedure ParseCookies;
function PrepareHeaders: AnsiString;
function InternalDoConnect(needssl: Boolean): Boolean;
function InternalConnect(needssl: Boolean): Boolean;
public
constructor Create;
destructor Destroy; override;
{:Reset headers and document and Mimetype.}
procedure Clear;
{:Decode ResultCode and ResultString from Value.}
procedure DecodeStatus(const Value: string);
{:Connects to host define in URL and access to resource defined in URL by
method. If Document is not empty, send it to server as part of HTTP request.
Server response is in Document and headers. Connection may be authorised
by username and password in URL. If you define proxy properties, connection
is made by this proxy. If all OK, result is @true, else result is @false.
If you use in URL 'https:' instead only 'http:', then your request is made
by SSL/TLS connection (if you not specify port, then port 443 is used
instead standard port 80). If you use SSL/TLS request and you have defined
HTTP proxy, then HTTP-tunnel mode is automaticly used .}
function HTTPMethod(const Method, URL: string): Boolean;
{:You can call this method from OnStatus event for break current data
transfer. (or from another thread.)}
procedure Abort;
published
{:Before HTTP operation you may define any non-standard headers for HTTP
request, except of: 'Expect: 100-continue', 'Content-Length', 'Content-Type',
'Connection', 'Authorization', 'Proxy-Authorization' and 'Host' headers.
After HTTP operation contains full headers of returned document.}
property Headers: TStringList read FHeaders;
{:This is stringlist with name-value stringlist pairs. Each this pair is one
cookie. After HTTP request is returned cookies parsed to this stringlist.
You can leave this cookies untouched for next HTTP request. You can also
save this stringlist for later use.}
property Cookies: TStringList read FCookies;
{:Stream with document to send (before request, or with document received
from HTTP server (after request).}
property Document: TMemoryStream read FDocument;
{:If you need download only part of requested document, here specify
possition of subpart begin. If here 0, then is requested full document.}
property RangeStart: integer read FRangeStart Write FRangeStart;
{:If you need download only part of requested document, here specify
possition of subpart end. If here 0, then is requested document from
rangeStart to end of document. (for broken download restoration,
for example.)}
property RangeEnd: integer read FRangeEnd Write FRangeEnd;
{:Mime type of sending data. Default is: 'text/html'.}
property MimeType: string read FMimeType Write FMimeType;
{:Define protocol version. Possible values are: '1.1', '1.0' (default)
and '0.9'.}
property Protocol: string read FProtocol Write FProtocol;
{:If @true (default value), keepalives in HTTP protocol 1.1 is enabled.}
property KeepAlive: Boolean read FKeepAlive Write FKeepAlive;
{:Define timeout for keepalives in seconds!}
property KeepAliveTimeout: integer read FKeepAliveTimeout Write FKeepAliveTimeout;
{:if @true, then server is requested for 100status capability when uploading
data. Default is @false (off).}
property Status100: Boolean read FStatus100 Write FStatus100;
{:Address of proxy server (IP address or domain name) where you want to
connect in @link(HTTPMethod) method.}
property ProxyHost: string read FProxyHost Write FProxyHost;
{:Port number for proxy connection. Default value is 8080.}
property ProxyPort: string read FProxyPort Write FProxyPort;
{:Username for connect to proxy server where you want to connect in
HTTPMethod method.}
property ProxyUser: string read FProxyUser Write FProxyUser;
{:Password for connect to proxy server where you want to connect in
HTTPMethod method.}
property ProxyPass: string read FProxyPass Write FProxyPass;
{:Here you can specify custom User-Agent indentification. By default is
used: 'Mozilla/4.0 (compatible; Synapse)'}
property UserAgent: string read FUserAgent Write FUserAgent;
{:After successful @link(HTTPMethod) method contains result code of
operation.}
property ResultCode: Integer read FResultCode;
{:After successful @link(HTTPMethod) method contains string after result code.}
property ResultString: string read FResultString;
{:if this value is not 0, then data download pending. In this case you have
here total sice of downloaded data. It is good for draw download
progressbar from OnStatus event.}
property DownloadSize: integer read FDownloadSize;
{:if this value is not 0, then data upload pending. In this case you have
here total sice of uploaded data. It is good for draw upload progressbar
from OnStatus event.}
property UploadSize: integer read FUploadSize;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{:To have possibility to switch off port number in 'Host:' HTTP header, by
default @TRUE. Some buggy servers not like port informations in this header.}
property AddPortNumberToHost: Boolean read FAddPortNumberToHost write FAddPortNumberToHost;
end;
{:A very usefull function, and example of use can be found in the THTTPSend
object. It implements the GET method of the HTTP protocol. This function sends
the GET method for URL document to an HTTP server. Returned document is in the
"Response" stringlist (without any headers). Returns boolean TRUE if all went
well.}
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
{:A very usefull function, and example of use can be found in the THTTPSend
object. It implements the GET method of the HTTP protocol. This function sends
the GET method for URL document to an HTTP server. Returned document is in the
"Response" stream. Returns boolean TRUE if all went well.}
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function sends
the SEND method for a URL document to an HTTP server. The document to be sent
is located in "Data" stream. The returned document is in the "Data" stream.
Returns boolean TRUE if all went well.}
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function is
good for POSTing form data. It sends the POST method for a URL document to
an HTTP server. You must prepare the form data in the same manner as you would
the URL data, and pass this prepared data to "URLdata". The following is
a sample of how the data would appear: 'name=Lukas&field1=some%20data'.
The information in the field must be encoded by EncodeURLElement function.
The returned document is in the "Data" stream. Returns boolean TRUE if all
went well.}
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
{:A very useful function, and example of use can be found in the THTTPSend
object. It implements the POST method of the HTTP protocol. This function sends
the POST method for a URL document to an HTTP server. This function simulate
posting of file by HTML form used method 'multipart/form-data'. Posting file
is in DATA stream. Its name is Filename string. Fieldname is for name of
formular field with file. (simulate HTML INPUT FILE) The returned document is
in the ResultData Stringlist. Returns boolean TRUE if all went well.}
function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStrings): Boolean;
implementation
constructor THTTPSend.Create;
begin
inherited Create;
FHeaders := TStringList.Create;
FCookies := TStringList.Create;
FDocument := TMemoryStream.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := True;
FSock.SizeRecvBuffer := c64k;
FSock.SizeSendBuffer := c64k;
FTimeout := 90000;
FTargetPort := cHttpProtocol;
FProxyHost := '';
FProxyPort := '8080';
FProxyUser := '';
FProxyPass := '';
FAliveHost := '';
FAlivePort := '';
FProtocol := '1.0';
FKeepAlive := True;
FStatus100 := False;
FUserAgent := 'Mozilla/4.0 (compatible; Synapse)';
FDownloadSize := 0;
FUploadSize := 0;
FAddPortNumberToHost := true;
FKeepAliveTimeout := 300;
Clear;
end;
destructor THTTPSend.Destroy;
begin
FSock.Free;
FDocument.Free;
FCookies.Free;
FHeaders.Free;
inherited Destroy;
end;
procedure THTTPSend.Clear;
begin
FRangeStart := 0;
FRangeEnd := 0;
FDocument.Clear;
FHeaders.Clear;
FMimeType := 'text/html';
end;
procedure THTTPSend.DecodeStatus(const Value: string);
var
s, su: string;
begin
s := Trim(SeparateRight(Value, ' '));
su := Trim(SeparateLeft(s, ' '));
FResultCode := StrToIntDef(su, 0);
FResultString := Trim(SeparateRight(s, ' '));
if FResultString = s then
FResultString := '';
end;
function THTTPSend.PrepareHeaders: AnsiString;
begin
if FProtocol = '0.9' then
Result := FHeaders[0] + CRLF
else
{$IFNDEF MSWINDOWS}
Result := {$IFDEF UNICODE}AnsiString{$ENDIF}(AdjustLineBreaks(FHeaders.Text, tlbsCRLF));
{$ELSE}
Result := FHeaders.Text;
{$ENDIF}
end;
function THTTPSend.InternalDoConnect(needssl: Boolean): Boolean;
begin
Result := False;
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError <> 0 then
Exit;
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError <> 0 then
Exit;
if needssl then
begin
if (FSock.SSL.SNIHost='') then
FSock.SSL.SNIHost:=FTargetHost;
FSock.SSLDoConnect;
FSock.SSL.SNIHost:=''; //don't need it anymore and don't wan't to reuse it in next connection
if FSock.LastError <> 0 then
Exit;
end;
FAliveHost := FTargetHost;
FAlivePort := FTargetPort;
Result := True;
end;
function THTTPSend.InternalConnect(needssl: Boolean): Boolean;
begin
if FSock.Socket = INVALID_SOCKET then
Result := InternalDoConnect(needssl)
else
if (FAliveHost <> FTargetHost) or (FAlivePort <> FTargetPort)
or FSock.CanRead(0) then
Result := InternalDoConnect(needssl)
else
Result := True;
end;
function THTTPSend.HTTPMethod(const Method, URL: string): Boolean;
var
Sending, Receiving: Boolean;
status100: Boolean;
status100error: string;
ToClose: Boolean;
Size: Integer;
Prot, User, Pass, Host, Port, Path, Para, URI: string;
s, su: AnsiString;
HttpTunnel: Boolean;
n: integer;
pp: string;
UsingProxy: boolean;
l: TStringList;
x: integer;
begin
{initial values}
Result := False;
FResultCode := 500;
FResultString := '';
FDownloadSize := 0;
FUploadSize := 0;
URI := ParseURL(URL, Prot, User, Pass, Host, Port, Path, Para);
User := DecodeURL(user);
Pass := DecodeURL(pass);
if User = '' then
begin
User := FUsername;
Pass := FPassword;
end;
if UpperCase(Prot) = 'HTTPS' then
begin
HttpTunnel := FProxyHost <> '';
FSock.HTTPTunnelIP := FProxyHost;
FSock.HTTPTunnelPort := FProxyPort;
FSock.HTTPTunnelUser := FProxyUser;
FSock.HTTPTunnelPass := FProxyPass;
end
else
begin
HttpTunnel := False;
FSock.HTTPTunnelIP := '';
FSock.HTTPTunnelPort := '';
FSock.HTTPTunnelUser := '';
FSock.HTTPTunnelPass := '';
end;
UsingProxy := (FProxyHost <> '') and not(HttpTunnel);
Sending := FDocument.Size > 0;
{Headers for Sending data}
status100 := FStatus100 and Sending and (FProtocol = '1.1');
if status100 then
FHeaders.Insert(0, 'Expect: 100-continue');
if Sending then
begin
FHeaders.Insert(0, 'Content-Length: ' + IntToStr(FDocument.Size));
if FMimeType <> '' then
FHeaders.Insert(0, 'Content-Type: ' + FMimeType);
end;
{ setting User-agent }
if FUserAgent <> '' then
FHeaders.Insert(0, 'User-Agent: ' + FUserAgent);
{ setting Ranges }
if (FRangeStart > 0) or (FRangeEnd > 0) then
begin
if FRangeEnd >= FRangeStart then
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-' + IntToStr(FRangeEnd))
else
FHeaders.Insert(0, 'Range: bytes=' + IntToStr(FRangeStart) + '-');
end;
{ setting Cookies }
s := '';
for n := 0 to FCookies.Count - 1 do
begin
if s <> '' then
s := s + '; ';
s := s + FCookies[n];
end;
if s <> '' then
FHeaders.Insert(0, 'Cookie: ' + s);
{ setting KeepAlives }
pp := '';
if UsingProxy then
pp := 'Proxy-';
if FKeepAlive then
begin
FHeaders.Insert(0, pp + 'Connection: keep-alive');
FHeaders.Insert(0, 'Keep-Alive: ' + IntToStr(FKeepAliveTimeout));
end
else
FHeaders.Insert(0, pp + 'Connection: close');
{ set target servers/proxy, authorizations, etc... }
if User <> '' then
FHeaders.Insert(0, 'Authorization: Basic ' + EncodeBase64(User + ':' + Pass));
if UsingProxy and (FProxyUser <> '') then
FHeaders.Insert(0, 'Proxy-Authorization: Basic ' +
EncodeBase64(FProxyUser + ':' + FProxyPass));
if isIP6(Host) then
s := '[' + Host + ']'
else
s := Host;
if FAddPortNumberToHost and (Port <> '80') then
FHeaders.Insert(0, 'Host: ' + s + ':' + Port)
else
FHeaders.Insert(0, 'Host: ' + s);
if UsingProxy then
URI := Prot + '://' + s + ':' + Port + URI;
if URI = '/*' then
URI := '*';
if FProtocol = '0.9' then
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI)
else
FHeaders.Insert(0, UpperCase(Method) + ' ' + URI + ' HTTP/' + FProtocol);
if UsingProxy then
begin
FTargetHost := FProxyHost;
FTargetPort := FProxyPort;
end
else
begin
FTargetHost := Host;
FTargetPort := Port;
end;
if FHeaders[FHeaders.Count - 1] <> '' then
FHeaders.Add('');
{ connect }
if not InternalConnect(UpperCase(Prot) = 'HTTPS') then
begin
FAliveHost := '';
FAlivePort := '';
Exit;
end;
{ reading Status }
FDocument.Position := 0;
Status100Error := '';
if status100 then
begin
{ send Headers }
FSock.SendString(PrepareHeaders);
if FSock.LastError <> 0 then
Exit;
repeat
s := FSock.RecvString(FTimeout);
if s <> '' then
Break;
until FSock.LastError <> 0;
DecodeStatus(s);
Status100Error := s;
repeat
s := FSock.recvstring(FTimeout);
if s = '' then
Break;
until FSock.LastError <> 0;
if (FResultCode >= 100) and (FResultCode < 200) then
begin
{ we can upload content }
Status100Error := '';
FUploadSize := FDocument.Size;
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
end;
end
else
{ upload content }
if sending then
begin
if FDocument.Size >= c64k then
begin
FSock.SendString(PrepareHeaders);
FUploadSize := FDocument.Size;
FSock.SendBuffer(FDocument.Memory, FDocument.Size);
end
else
begin
s := PrepareHeaders + ReadStrFromStream(FDocument, FDocument.Size);
FUploadSize := Length(s);
FSock.SendString(s);
end;
end
else
begin
{ we not need to upload document, send headers only }
FSock.SendString(PrepareHeaders);
end;
if FSock.LastError <> 0 then
Exit;
Clear;
Size := -1;
FTransferEncoding := TE_UNKNOWN;
{ read status }
if Status100Error = '' then
begin
repeat
repeat
s := FSock.RecvString(FTimeout);
if s <> '' then
Break;
until FSock.LastError <> 0;
if Pos('HTTP/', UpperCase(s)) = 1 then
begin
FHeaders.Add(s);
DecodeStatus(s);
end
else
begin
{ old HTTP 0.9 and some buggy servers not send result }
s := s + CRLF;
WriteStrToStream(FDocument, s);
FResultCode := 0;
end;
until (FSock.LastError <> 0) or (FResultCode <> 100);
end
else
FHeaders.Add(Status100Error);
{ if need receive headers, receive and parse it }
ToClose := FProtocol <> '1.1';
if FHeaders.Count > 0 then
begin
l := TStringList.Create;
try
repeat
s := FSock.RecvString(FTimeout);
l.Add(s);
if s = '' then
Break;
until FSock.LastError <> 0;
x := 0;
while l.Count > x do
begin
s := NormalizeHeader(l, x);
FHeaders.Add(s);
su := UpperCase(s);
if Pos('CONTENT-LENGTH:', su) = 1 then
begin
Size := StrToIntDef(Trim(SeparateRight(s, ' ')), -1);
if (Size <> -1) and (FTransferEncoding = TE_UNKNOWN) then
FTransferEncoding := TE_IDENTITY;
end;
if Pos('CONTENT-TYPE:', su) = 1 then
FMimeType := Trim(SeparateRight(s, ' '));
if Pos('TRANSFER-ENCODING:', su) = 1 then
begin
s := Trim(SeparateRight(su, ' '));
if Pos('CHUNKED', s) > 0 then
FTransferEncoding := TE_CHUNKED;
end;
if UsingProxy then
begin
if Pos('PROXY-CONNECTION:', su) = 1 then
if Pos('CLOSE', su) > 0 then
ToClose := True;
end
else
begin
if Pos('CONNECTION:', su) = 1 then
if Pos('CLOSE', su) > 0 then
ToClose := True;
end;
end;
finally
l.free;
end;
end;
Result := FSock.LastError = 0;
if not Result then
Exit;
{if need receive response body, read it}
Receiving := Method <> 'HEAD';
Receiving := Receiving and (FResultCode <> 204);
Receiving := Receiving and (FResultCode <> 304);
if Receiving then
case FTransferEncoding of
TE_UNKNOWN:
Result := ReadUnknown;
TE_IDENTITY:
Result := ReadIdentity(Size);
TE_CHUNKED:
Result := ReadChunked;
end;
FDocument.Seek(0, soFromBeginning);
if ToClose then
begin
FSock.CloseSocket;
FAliveHost := '';
FAlivePort := '';
end;
ParseCookies;
end;
function THTTPSend.ReadUnknown: Boolean;
var
s: ansistring;
begin
Result := false;
repeat
s := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
WriteStrToStream(FDocument, s);
until FSock.LastError <> 0;
if FSock.LastError = WSAECONNRESET then
begin
Result := true;
FSock.ResetLastError;
end;
end;
function THTTPSend.ReadIdentity(Size: Integer): Boolean;
begin
if Size > 0 then
begin
FDownloadSize := Size;
FSock.RecvStreamSize(FDocument, FTimeout, Size);
FDocument.Position := FDocument.Size;
Result := FSock.LastError = 0;
end
else
Result := true;
end;
function THTTPSend.ReadChunked: Boolean;
var
s: ansistring;
Size: Integer;
begin
repeat
repeat
s := FSock.RecvString(FTimeout);
until (s <> '') or (FSock.LastError <> 0);
if FSock.LastError <> 0 then
Break;
s := Trim(SeparateLeft(s, ' '));
s := Trim(SeparateLeft(s, ';'));
Size := StrToIntDef('$' + s, 0);
if Size = 0 then
Break;
if not ReadIdentity(Size) then
break;
until False;
Result := FSock.LastError = 0;
end;
procedure THTTPSend.ParseCookies;
var
n: integer;
s: string;
sn, sv: string;
begin
for n := 0 to FHeaders.Count - 1 do
if Pos('set-cookie:', lowercase(FHeaders[n])) = 1 then
begin
s := SeparateRight(FHeaders[n], ':');
s := trim(SeparateLeft(s, ';'));
sn := trim(SeparateLeft(s, '='));
sv := trim(SeparateRight(s, '='));
FCookies.Values[sn] := sv;
end;
end;
procedure THTTPSend.Abort;
begin
FSock.StopFlag := True;
end;
{==============================================================================}
function HttpGetText(const URL: string; const Response: TStrings): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
Result := HTTP.HTTPMethod('GET', URL);
if Result then
Response.LoadFromStream(HTTP.Document);
finally
HTTP.Free;
end;
end;
function HttpGetBinary(const URL: string; const Response: TStream): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
Result := HTTP.HTTPMethod('GET', URL);
if Result then
begin
Response.Seek(0, soFromBeginning);
Response.CopyFrom(HTTP.Document, 0);
end;
finally
HTTP.Free;
end;
end;
function HttpPostBinary(const URL: string; const Data: TStream): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
HTTP.Document.CopyFrom(Data, 0);
HTTP.MimeType := 'Application/octet-stream';
Result := HTTP.HTTPMethod('POST', URL);
Data.Size := 0;
if Result then
begin
Data.Seek(0, soFromBeginning);
Data.CopyFrom(HTTP.Document, 0);
end;
finally
HTTP.Free;
end;
end;
function HttpPostURL(const URL, URLData: string; const Data: TStream): Boolean;
var
HTTP: THTTPSend;
begin
HTTP := THTTPSend.Create;
try
WriteStrToStream(HTTP.Document, URLData);
HTTP.MimeType := 'application/x-www-form-urlencoded';
Result := HTTP.HTTPMethod('POST', URL);
if Result then
Data.CopyFrom(HTTP.Document, 0);
finally
HTTP.Free;
end;
end;
function HttpPostFile(const URL, FieldName, FileName: string;
const Data: TStream; const ResultData: TStrings): Boolean;
var
HTTP: THTTPSend;
Bound, s: string;
begin
Bound := IntToHex(Random(MaxInt), 8) + '_Synapse_boundary';
HTTP := THTTPSend.Create;
try
s := '--' + Bound + CRLF;
s := s + 'content-disposition: form-data; name="' + FieldName + '";';
s := s + ' filename="' + FileName +'"' + CRLF;
s := s + 'Content-Type: Application/octet-string' + CRLF + CRLF;
WriteStrToStream(HTTP.Document, s);
HTTP.Document.CopyFrom(Data, 0);
s := CRLF + '--' + Bound + '--' + CRLF;
WriteStrToStream(HTTP.Document, s);
HTTP.MimeType := 'multipart/form-data; boundary=' + Bound;
Result := HTTP.HTTPMethod('POST', URL);
if Result then
ResultData.LoadFromStream(HTTP.Document);
finally
HTTP.Free;
end;
end;
end.

869
synapse/imapsend.pas Normal file
View File

@ -0,0 +1,869 @@
{==============================================================================|
| Project : Ararat Synapse | 002.005.003 |
|==============================================================================|
| Content: IMAP4rev1 client |
|==============================================================================|
| Copyright (c)1999-2012, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(IMAP4 rev1 protocol client)
Used RFC: RFC-2060, RFC-2595
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit imapsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cIMAPProtocol = '143';
type
{:@abstract(Implementation of IMAP4 protocol.)
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TIMAPSend = class(TSynaClient)
protected
FSock: TTCPBlockSocket;
FTagCommand: integer;
FResultString: string;
FFullResult: TStringList;
FIMAPcap: TStringList;
FAuthDone: Boolean;
FSelectedFolder: string;
FSelectedCount: integer;
FSelectedRecent: integer;
FSelectedUIDvalidity: integer;
FUID: Boolean;
FAutoTLS: Boolean;
FFullSSL: Boolean;
function ReadResult: string;
function AuthLogin: Boolean;
function Connect: Boolean;
procedure ParseMess(Value:TStrings);
procedure ParseFolderList(Value:TStrings);
procedure ParseSelect;
procedure ParseSearch(Value:TStrings);
procedure ProcessLiterals;
public
constructor Create;
destructor Destroy; override;
{:By this function you can call any IMAP command. Result of this command is
in adequate properties.}
function IMAPcommand(Value: string): string;
{:By this function you can call any IMAP command what need upload any data.
Result of this command is in adequate properties.}
function IMAPuploadCommand(Value: string; const Data:TStrings): string;
{:Call CAPABILITY command and fill IMAPcap property by new values.}
function Capability: Boolean;
{:Connect to IMAP server and do login to this server. This command begin
session.}
function Login: Boolean;
{:Disconnect from IMAP server and terminate session session. If exists some
deleted and non-purged messages, these messages are not deleted!}
function Logout: Boolean;
{:Do NOOP. It is for prevent disconnect by timeout.}
function NoOp: Boolean;
{:Lists folder names. You may specify level of listing. If you specify
FromFolder as empty string, return is all folders in system.}
function List(FromFolder: string; const FolderList: TStrings): Boolean;
{:Lists folder names what match search criteria. You may specify level of
listing. If you specify FromFolder as empty string, return is all folders
in system.}
function ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
{:Lists subscribed folder names. You may specify level of listing. If you
specify FromFolder as empty string, return is all subscribed folders in
system.}
function ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
{:Lists subscribed folder names what matching search criteria. You may
specify level of listing. If you specify FromFolder as empty string, return
is all subscribed folders in system.}
function ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
{:Create a new folder.}
function CreateFolder(FolderName: string): Boolean;
{:Delete a folder.}
function DeleteFolder(FolderName: string): Boolean;
{:Rename folder names.}
function RenameFolder(FolderName, NewFolderName: string): Boolean;
{:Subscribe folder.}
function SubscribeFolder(FolderName: string): Boolean;
{:Unsubscribe folder.}
function UnsubscribeFolder(FolderName: string): Boolean;
{:Select folder.}
function SelectFolder(FolderName: string): Boolean;
{:Select folder, but only for reading. Any changes are not allowed!}
function SelectROFolder(FolderName: string): Boolean;
{:Close a folder. (end of Selected state)}
function CloseFolder: Boolean;
{:Ask for given status of folder. I.e. if you specify as value 'UNSEEN',
result is number of unseen messages in folder. For another status
indentificator check IMAP documentation and documentation of your IMAP
server (each IMAP server can have their own statuses.)}
function StatusFolder(FolderName, Value: string): integer;
{:Hardly delete all messages marked as 'deleted' in current selected folder.}
function ExpungeFolder: Boolean;
{:Touch to folder. (use as update status of folder, etc.)}
function CheckFolder: Boolean;
{:Append given message to specified folder.}
function AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
{:'Delete' message from current selected folder. It mark message as Deleted.
Real deleting will be done after sucessfull @link(CloseFolder) or
@link(ExpungeFolder)}
function DeleteMess(MessID: integer): boolean;
{:Get full message from specified message in selected folder.}
function FetchMess(MessID: integer; const Mess: TStrings): Boolean;
{:Get message headers only from specified message in selected folder.}
function FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
{:Return message size of specified message from current selected folder.}
function MessageSize(MessID: integer): integer;
{:Copy message from current selected folder to another folder.}
function CopyMess(MessID: integer; ToFolder: string): Boolean;
{:Return message numbers from currently selected folder as result
of searching. Search criteria is very complex language (see to IMAP
specification) similar to SQL (but not same syntax!).}
function SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
{:Sets flags of message from current selected folder.}
function SetFlagsMess(MessID: integer; Flags: string): Boolean;
{:Gets flags of message from current selected folder.}
function GetFlagsMess(MessID: integer; var Flags: string): Boolean;
{:Add flags to message's flags.}
function AddFlagsMess(MessID: integer; Flags: string): Boolean;
{:Remove flags from message's flags.}
function DelFlagsMess(MessID: integer; Flags: string): Boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:return UID of requested message ID.}
function GetUID(MessID: integer; var UID : Integer): Boolean;
{:Try to find given capabily in capabilty string returned from IMAP server.}
function FindCap(const Value: string): string;
published
{:Status line with result of last operation.}
property ResultString: string read FResultString;
{:Full result of last IMAP operation.}
property FullResult: TStringList read FFullResult;
{:List of server capabilites.}
property IMAPcap: TStringList read FIMAPcap;
{:Authorization is successful done.}
property AuthDone: Boolean read FAuthDone;
{:Turn on or off usage of UID (unicate identificator) of messages instead
only sequence numbers.}
property UID: Boolean read FUID Write FUID;
{:Name of currently selected folder.}
property SelectedFolder: string read FSelectedFolder;
{:Count of messages in currently selected folder.}
property SelectedCount: integer read FSelectedCount;
{:Count of not-visited messages in currently selected folder.}
property SelectedRecent: integer read FSelectedRecent;
{:This number with name of folder is unique indentificator of folder.
(If someone delete folder and next create new folder with exactly same name
of folder, this number is must be different!)}
property SelectedUIDvalidity: integer read FSelectedUIDvalidity;
{:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
end;
implementation
constructor TIMAPSend.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FIMAPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := True;
FSock.SizeRecvBuffer := 32768;
FSock.SizeSendBuffer := 32768;
FTimeout := 60000;
FTargetPort := cIMAPProtocol;
FTagCommand := 0;
FSelectedFolder := '';
FSelectedCount := 0;
FSelectedRecent := 0;
FSelectedUIDvalidity := 0;
FUID := False;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TIMAPSend.Destroy;
begin
FSock.Free;
FIMAPcap.Free;
FFullResult.Free;
inherited Destroy;
end;
function TIMAPSend.ReadResult: string;
var
s: string;
x, l: integer;
begin
Result := '';
FFullResult.Clear;
FResultString := '';
repeat
s := FSock.RecvString(FTimeout);
if Pos('S' + IntToStr(FTagCommand) + ' ', s) = 1 then
begin
FResultString := s;
break;
end
else
FFullResult.Add(s);
if (s <> '') and (s[Length(s)]='}') then
begin
s := Copy(s, 1, Length(s) - 1);
x := RPos('{', s);
s := Copy(s, x + 1, Length(s) - x);
l := StrToIntDef(s, -1);
if l <> -1 then
begin
s := FSock.RecvBufferStr(l, FTimeout);
FFullResult.Add(s);
end;
end;
until FSock.LastError <> 0;
s := Trim(separateright(FResultString, ' '));
Result:=uppercase(Trim(separateleft(s, ' ')));
end;
procedure TIMAPSend.ProcessLiterals;
var
l: TStringList;
n, x: integer;
b: integer;
s: string;
begin
l := TStringList.Create;
try
l.Assign(FFullResult);
FFullResult.Clear;
b := 0;
for n := 0 to l.Count - 1 do
begin
s := l[n];
if b > 0 then
begin
FFullResult[FFullresult.Count - 1] :=
FFullResult[FFullresult.Count - 1] + s;
inc(b);
if b > 2 then
b := 0;
end
else
begin
if (s <> '') and (s[Length(s)]='}') then
begin
x := RPos('{', s);
Delete(s, x, Length(s) - x + 1);
b := 1;
end
else
b := 0;
FFullResult.Add(s);
end;
end;
finally
l.Free;
end;
end;
function TIMAPSend.IMAPcommand(Value: string): string;
begin
Inc(FTagCommand);
FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + CRLF);
Result := ReadResult;
end;
function TIMAPSend.IMAPuploadCommand(Value: string; const Data:TStrings): string;
var
l: integer;
begin
Inc(FTagCommand);
l := Length(Data.Text);
FSock.SendString('S' + IntToStr(FTagCommand) + ' ' + Value + ' {'+ IntToStr(l) + '}' + CRLF);
FSock.RecvString(FTimeout);
FSock.SendString(Data.Text + CRLF);
Result := ReadResult;
end;
procedure TIMAPSend.ParseMess(Value:TStrings);
var
n: integer;
begin
Value.Clear;
for n := 0 to FFullResult.Count - 2 do
if (length(FFullResult[n]) > 0) and (FFullResult[n][Length(FFullResult[n])] = '}') then
begin
Value.Text := FFullResult[n + 1];
Break;
end;
end;
procedure TIMAPSend.ParseFolderList(Value:TStrings);
var
n, x: integer;
s: string;
begin
ProcessLiterals;
Value.Clear;
for n := 0 to FFullResult.Count - 1 do
begin
s := FFullResult[n];
if (s <> '') and (Pos('\NOSELECT', UpperCase(s)) = 0) then
begin
if s[Length(s)] = '"' then
begin
Delete(s, Length(s), 1);
x := RPos('"', s);
end
else
x := RPos(' ', s);
if (x > 0) then
Value.Add(Copy(s, x + 1, Length(s) - x));
end;
end;
end;
procedure TIMAPSend.ParseSelect;
var
n: integer;
s, t: string;
begin
ProcessLiterals;
FSelectedCount := 0;
FSelectedRecent := 0;
FSelectedUIDvalidity := 0;
for n := 0 to FFullResult.Count - 1 do
begin
s := uppercase(FFullResult[n]);
if Pos(' EXISTS', s) > 0 then
begin
t := Trim(separateleft(s, ' EXISTS'));
t := Trim(separateright(t, '* '));
FSelectedCount := StrToIntDef(t, 0);
end;
if Pos(' RECENT', s) > 0 then
begin
t := Trim(separateleft(s, ' RECENT'));
t := Trim(separateright(t, '* '));
FSelectedRecent := StrToIntDef(t, 0);
end;
if Pos('UIDVALIDITY', s) > 0 then
begin
t := Trim(separateright(s, 'UIDVALIDITY '));
t := Trim(separateleft(t, ']'));
FSelectedUIDvalidity := StrToIntDef(t, 0);
end;
end;
end;
procedure TIMAPSend.ParseSearch(Value:TStrings);
var
n: integer;
s: string;
begin
ProcessLiterals;
Value.Clear;
for n := 0 to FFullResult.Count - 1 do
begin
s := uppercase(FFullResult[n]);
if Pos('* SEARCH', s) = 1 then
begin
s := Trim(SeparateRight(s, '* SEARCH'));
while s <> '' do
Value.Add(Fetch(s, ' '));
end;
end;
end;
function TIMAPSend.FindCap(const Value: string): string;
var
n: Integer;
s: string;
begin
s := UpperCase(Value);
Result := '';
for n := 0 to FIMAPcap.Count - 1 do
if Pos(s, UpperCase(FIMAPcap[n])) = 1 then
begin
Result := FIMAPcap[n];
Break;
end;
end;
function TIMAPSend.AuthLogin: Boolean;
begin
Result := IMAPcommand('LOGIN "' + FUsername + '" "' + FPassword + '"') = 'OK';
end;
function TIMAPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TIMAPSend.Capability: Boolean;
var
n: Integer;
s, t: string;
begin
Result := False;
FIMAPcap.Clear;
s := IMAPcommand('CAPABILITY');
if s = 'OK' then
begin
ProcessLiterals;
for n := 0 to FFullResult.Count - 1 do
if Pos('* CAPABILITY ', FFullResult[n]) = 1 then
begin
s := Trim(SeparateRight(FFullResult[n], '* CAPABILITY '));
while not (s = '') do
begin
t := Trim(separateleft(s, ' '));
s := Trim(separateright(s, ' '));
if s = t then
s := '';
FIMAPcap.Add(t);
end;
end;
Result := True;
end;
end;
function TIMAPSend.Login: Boolean;
var
s: string;
begin
FSelectedFolder := '';
FSelectedCount := 0;
FSelectedRecent := 0;
FSelectedUIDvalidity := 0;
Result := False;
FAuthDone := False;
if not Connect then
Exit;
s := FSock.RecvString(FTimeout);
if Pos('* PREAUTH', s) = 1 then
FAuthDone := True
else
if Pos('* OK', s) = 1 then
FAuthDone := False
else
Exit;
if Capability then
begin
if Findcap('IMAP4rev1') = '' then
Exit;
if FAutoTLS and (Findcap('STARTTLS') <> '') then
if StartTLS then
Capability;
end;
Result := AuthLogin;
end;
function TIMAPSend.Logout: Boolean;
begin
Result := IMAPcommand('LOGOUT') = 'OK';
FSelectedFolder := '';
FSock.CloseSocket;
end;
function TIMAPSend.NoOp: Boolean;
begin
Result := IMAPcommand('NOOP') = 'OK';
end;
function TIMAPSend.List(FromFolder: string; const FolderList: TStrings): Boolean;
begin
Result := IMAPcommand('LIST "' + FromFolder + '" *') = 'OK';
ParseFolderList(FolderList);
end;
function TIMAPSend.ListSearch(FromFolder, Search: string; const FolderList: TStrings): Boolean;
begin
Result := IMAPcommand('LIST "' + FromFolder + '" "' + Search +'"') = 'OK';
ParseFolderList(FolderList);
end;
function TIMAPSend.ListSubscribed(FromFolder: string; const FolderList: TStrings): Boolean;
begin
Result := IMAPcommand('LSUB "' + FromFolder + '" *') = 'OK';
ParseFolderList(FolderList);
end;
function TIMAPSend.ListSearchSubscribed(FromFolder, Search: string; const FolderList: TStrings): Boolean;
begin
Result := IMAPcommand('LSUB "' + FromFolder + '" "' + Search +'"') = 'OK';
ParseFolderList(FolderList);
end;
function TIMAPSend.CreateFolder(FolderName: string): Boolean;
begin
Result := IMAPcommand('CREATE "' + FolderName + '"') = 'OK';
end;
function TIMAPSend.DeleteFolder(FolderName: string): Boolean;
begin
Result := IMAPcommand('DELETE "' + FolderName + '"') = 'OK';
end;
function TIMAPSend.RenameFolder(FolderName, NewFolderName: string): Boolean;
begin
Result := IMAPcommand('RENAME "' + FolderName + '" "' + NewFolderName + '"') = 'OK';
end;
function TIMAPSend.SubscribeFolder(FolderName: string): Boolean;
begin
Result := IMAPcommand('SUBSCRIBE "' + FolderName + '"') = 'OK';
end;
function TIMAPSend.UnsubscribeFolder(FolderName: string): Boolean;
begin
Result := IMAPcommand('UNSUBSCRIBE "' + FolderName + '"') = 'OK';
end;
function TIMAPSend.SelectFolder(FolderName: string): Boolean;
begin
Result := IMAPcommand('SELECT "' + FolderName + '"') = 'OK';
FSelectedFolder := FolderName;
ParseSelect;
end;
function TIMAPSend.SelectROFolder(FolderName: string): Boolean;
begin
Result := IMAPcommand('EXAMINE "' + FolderName + '"') = 'OK';
FSelectedFolder := FolderName;
ParseSelect;
end;
function TIMAPSend.CloseFolder: Boolean;
begin
Result := IMAPcommand('CLOSE') = 'OK';
FSelectedFolder := '';
end;
function TIMAPSend.StatusFolder(FolderName, Value: string): integer;
var
n: integer;
s, t: string;
begin
Result := -1;
Value := Uppercase(Value);
if IMAPcommand('STATUS "' + FolderName + '" (' + Value + ')' ) = 'OK' then
begin
ProcessLiterals;
for n := 0 to FFullResult.Count - 1 do
begin
s := FFullResult[n];
// s := UpperCase(FFullResult[n]);
if (Pos('* ', s) = 1) and (Pos(FolderName, s) >= 1) and (Pos(Value, s) > 0 ) then
begin
t := SeparateRight(s, Value);
t := SeparateLeft(t, ')');
t := trim(t);
Result := StrToIntDef(t, -1);
Break;
end;
end;
end;
end;
function TIMAPSend.ExpungeFolder: Boolean;
begin
Result := IMAPcommand('EXPUNGE') = 'OK';
end;
function TIMAPSend.CheckFolder: Boolean;
begin
Result := IMAPcommand('CHECK') = 'OK';
end;
function TIMAPSend.AppendMess(ToFolder: string; const Mess: TStrings): Boolean;
begin
Result := IMAPuploadCommand('APPEND "' + ToFolder + '"', Mess) = 'OK';
end;
function TIMAPSend.DeleteMess(MessID: integer): boolean;
var
s: string;
begin
s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (\Deleted)';
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
end;
function TIMAPSend.FetchMess(MessID: integer; const Mess: TStrings): Boolean;
var
s: string;
begin
s := 'FETCH ' + IntToStr(MessID) + ' (RFC822)';
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
ParseMess(Mess);
end;
function TIMAPSend.FetchHeader(MessID: integer; const Headers: TStrings): Boolean;
var
s: string;
begin
s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.HEADER)';
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
ParseMess(Headers);
end;
function TIMAPSend.MessageSize(MessID: integer): integer;
var
n: integer;
s, t: string;
begin
Result := -1;
s := 'FETCH ' + IntToStr(MessID) + ' (RFC822.SIZE)';
if FUID then
s := 'UID ' + s;
if IMAPcommand(s) = 'OK' then
begin
ProcessLiterals;
for n := 0 to FFullResult.Count - 1 do
begin
s := UpperCase(FFullResult[n]);
if (Pos('* ', s) = 1) and (Pos('RFC822.SIZE', s) > 0 ) then
begin
t := SeparateRight(s, 'RFC822.SIZE ');
t := Trim(SeparateLeft(t, ')'));
t := Trim(SeparateLeft(t, ' '));
Result := StrToIntDef(t, -1);
Break;
end;
end;
end;
end;
function TIMAPSend.CopyMess(MessID: integer; ToFolder: string): Boolean;
var
s: string;
begin
s := 'COPY ' + IntToStr(MessID) + ' "' + ToFolder + '"';
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
end;
function TIMAPSend.SearchMess(Criteria: string; const FoundMess: TStrings): Boolean;
var
s: string;
begin
s := 'SEARCH ' + Criteria;
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
ParseSearch(FoundMess);
end;
function TIMAPSend.SetFlagsMess(MessID: integer; Flags: string): Boolean;
var
s: string;
begin
s := 'STORE ' + IntToStr(MessID) + ' FLAGS.SILENT (' + Flags + ')';
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
end;
function TIMAPSend.AddFlagsMess(MessID: integer; Flags: string): Boolean;
var
s: string;
begin
s := 'STORE ' + IntToStr(MessID) + ' +FLAGS.SILENT (' + Flags + ')';
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
end;
function TIMAPSend.DelFlagsMess(MessID: integer; Flags: string): Boolean;
var
s: string;
begin
s := 'STORE ' + IntToStr(MessID) + ' -FLAGS.SILENT (' + Flags + ')';
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
end;
function TIMAPSend.GetFlagsMess(MessID: integer; var Flags: string): Boolean;
var
s: string;
n: integer;
begin
Flags := '';
s := 'FETCH ' + IntToStr(MessID) + ' (FLAGS)';
if FUID then
s := 'UID ' + s;
Result := IMAPcommand(s) = 'OK';
ProcessLiterals;
for n := 0 to FFullResult.Count - 1 do
begin
s := uppercase(FFullResult[n]);
if (Pos('* ', s) = 1) and (Pos('FLAGS', s) > 0 ) then
begin
s := SeparateRight(s, 'FLAGS');
s := Separateright(s, '(');
Flags := Trim(SeparateLeft(s, ')'));
end;
end;
end;
function TIMAPSend.StartTLS: Boolean;
begin
Result := False;
if FindCap('STARTTLS') <> '' then
begin
if IMAPcommand('STARTTLS') = 'OK' then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
end;
//Paul Buskermolen <p.buskermolen@pinkroccade.com>
function TIMAPSend.GetUID(MessID: integer; var UID : Integer): boolean;
var
s, sUid: string;
n: integer;
begin
sUID := '';
s := 'FETCH ' + IntToStr(MessID) + ' UID';
Result := IMAPcommand(s) = 'OK';
ProcessLiterals;
for n := 0 to FFullResult.Count - 1 do
begin
s := uppercase(FFullResult[n]);
if Pos('FETCH (UID', s) >= 1 then
begin
s := Separateright(s, '(UID ');
sUID := Trim(SeparateLeft(s, ')'));
end;
end;
UID := StrToIntDef(sUID, 0);
end;
{==============================================================================}
end.

170
synapse/laz_synapse.lpk Normal file
View File

@ -0,0 +1,170 @@
<?xml version="1.0"?>
<CONFIG>
<Package Version="3">
<Name Value="laz_synapse"/>
<CompilerOptions>
<Version Value="8"/>
<SearchPaths>
<UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)/"/>
</SearchPaths>
<Parsing>
<SyntaxOptions>
<UseAnsiStrings Value="True"/>
</SyntaxOptions>
</Parsing>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Files Count="33">
<Item1>
<Filename Value="asn1util.pas"/>
<UnitName Value="asn1util"/>
</Item1>
<Item2>
<Filename Value="blcksock.pas"/>
<UnitName Value="blcksock"/>
</Item2>
<Item3>
<Filename Value="clamsend.pas"/>
<UnitName Value="clamsend"/>
</Item3>
<Item4>
<Filename Value="dnssend.pas"/>
<UnitName Value="dnssend"/>
</Item4>
<Item5>
<Filename Value="ftpsend.pas"/>
<UnitName Value="ftpsend"/>
</Item5>
<Item6>
<Filename Value="ftptsend.pas"/>
<UnitName Value="ftptsend"/>
</Item6>
<Item7>
<Filename Value="httpsend.pas"/>
<UnitName Value="httpsend"/>
</Item7>
<Item8>
<Filename Value="imapsend.pas"/>
<UnitName Value="imapsend"/>
</Item8>
<Item9>
<Filename Value="ldapsend.pas"/>
<UnitName Value="ldapsend"/>
</Item9>
<Item10>
<Filename Value="mimeinln.pas"/>
<UnitName Value="mimeinln"/>
</Item10>
<Item11>
<Filename Value="mimemess.pas"/>
<UnitName Value="mimemess"/>
</Item11>
<Item12>
<Filename Value="mimepart.pas"/>
<UnitName Value="mimepart"/>
</Item12>
<Item13>
<Filename Value="nntpsend.pas"/>
<UnitName Value="nntpsend"/>
</Item13>
<Item14>
<Filename Value="pingsend.pas"/>
<UnitName Value="pingsend"/>
</Item14>
<Item15>
<Filename Value="pop3send.pas"/>
<UnitName Value="pop3send"/>
</Item15>
<Item16>
<Filename Value="slogsend.pas"/>
<UnitName Value="slogsend"/>
</Item16>
<Item17>
<Filename Value="smtpsend.pas"/>
<UnitName Value="smtpsend"/>
</Item17>
<Item18>
<Filename Value="snmpsend.pas"/>
<UnitName Value="snmpsend"/>
</Item18>
<Item19>
<Filename Value="sntpsend.pas"/>
<UnitName Value="sntpsend"/>
</Item19>
<Item20>
<Filename Value="ssfpc.pas"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="ssfpc"/>
</Item20>
<Item21>
<Filename Value="sswin32.pas"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="sswin32"/>
</Item21>
<Item22>
<Filename Value="synachar.pas"/>
<UnitName Value="synachar"/>
</Item22>
<Item23>
<Filename Value="synacode.pas"/>
<UnitName Value="synacode"/>
</Item23>
<Item24>
<Filename Value="synacrypt.pas"/>
<UnitName Value="synacrypt"/>
</Item24>
<Item25>
<Filename Value="synadbg.pas"/>
<UnitName Value="synadbg"/>
</Item25>
<Item26>
<Filename Value="synafpc.pas"/>
<UnitName Value="synafpc"/>
</Item26>
<Item27>
<Filename Value="synaicnv.pas"/>
<UnitName Value="synaicnv"/>
</Item27>
<Item28>
<Filename Value="synaip.pas"/>
<UnitName Value="synaip"/>
</Item28>
<Item29>
<Filename Value="synamisc.pas"/>
<UnitName Value="synamisc"/>
</Item29>
<Item30>
<Filename Value="synaser.pas"/>
<UnitName Value="synaser"/>
</Item30>
<Item31>
<Filename Value="synautil.pas"/>
<UnitName Value="synautil"/>
</Item31>
<Item32>
<Filename Value="synsock.pas"/>
<UnitName Value="synsock"/>
</Item32>
<Item33>
<Filename Value="tlntsend.pas"/>
<UnitName Value="tlntsend"/>
</Item33>
</Files>
<Type Value="RunAndDesignTime"/>
<RequiredPkgs Count="1">
<Item1>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item1>
</RequiredPkgs>
<UsageOptions>
<UnitPath Value="$(PkgOutDir)"/>
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>
</CONFIG>

24
synapse/laz_synapse.pas Normal file
View File

@ -0,0 +1,24 @@
{ This file was automatically created by Lazarus. Do not edit!
This source is only used to compile and install the package.
}
unit laz_synapse;
interface
uses
asn1util, blcksock, clamsend, dnssend, ftpsend, ftptsend, httpsend,
imapsend, ldapsend, mimeinln, mimemess, mimepart, nntpsend, pingsend,
pop3send, slogsend, smtpsend, snmpsend, sntpsend, synachar, synacode,
synacrypt, synadbg, synafpc, synaicnv, synaip, synamisc, synaser, synautil,
synsock, tlntsend, LazarusPackageIntf;
implementation
procedure Register;
begin
end;
initialization
RegisterPackage('laz_synapse', @Register);
end.

1208
synapse/ldapsend.pas Normal file
View File

File diff suppressed because it is too large Load Diff

28
synapse/licence.txt Normal file
View File

@ -0,0 +1,28 @@
Copyright (c)1999-2002, Lukas Gebauer
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
Redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer.
Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
Neither the name of Lukas Gebauer nor the names of its contributors may
be used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.

263
synapse/mimeinln.pas Normal file
View File

@ -0,0 +1,263 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.011 |
|==============================================================================|
| Content: Inline MIME support procedures and functions |
|==============================================================================|
| Copyright (c)1999-2006, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2006. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Utilities for inline MIME)
Support for Inline MIME encoding and decoding.
Used RFC: RFC-2047, RFC-2231
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit mimeinln;
interface
uses
SysUtils, Classes,
synachar, synacode, synautil;
{:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".}
function InlineDecode(const Value: string; CP: TMimeChar): string;
{:Encodes string to MIME inline encoding. The source characterset is "CP", and
the target charset is "MimeP".}
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
{:Returns @true, if "Value" contains characters needed for inline coding.}
function NeedInline(const Value: AnsiString): boolean;
{:Inline mime encoding similar to @link(InlineEncode), but you can specify
source charset, and the target characterset is automatically assigned.}
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
{:Inline MIME encoding similar to @link(InlineEncode), but the source charset
is automatically set to the system default charset, and the target charset is
automatically assigned from set of allowed encoding for MIME.}
function InlineCode(const Value: string): string;
{:Converts e-mail address to canonical mime form. You can specify source charset.}
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
{:Converts e-mail address to canonical mime form. Source charser it system
default charset.}
function InlineEmail(const Value: string): string;
implementation
{==============================================================================}
function InlineDecode(const Value: string; CP: TMimeChar): string;
var
s, su, v: string;
x, y, z, n: Integer;
ichar: TMimeChar;
c: Char;
function SearchEndInline(const Value: string; be: Integer): Integer;
var
n, q: Integer;
begin
q := 0;
Result := 0;
for n := be + 2 to Length(Value) - 1 do
if Value[n] = '?' then
begin
Inc(q);
if (q > 2) and (Value[n + 1] = '=') then
begin
Result := n;
Break;
end;
end;
end;
begin
Result := '';
v := Value;
x := Pos('=?', v);
y := SearchEndInline(v, x);
//fix for broken coding with begin, but not with end.
if (x > 0) and (y <= 0) then
y := Length(Result);
while (y > x) and (x > 0) do
begin
s := Copy(v, 1, x - 1);
if Trim(s) <> '' then
Result := Result + s;
s := Copy(v, x, y - x + 2);
Delete(v, 1, y + 1);
su := Copy(s, 3, Length(s) - 4);
z := Pos('?', su);
if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then
begin
ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*'));
c := UpperCase(su)[z + 1];
su := Copy(su, z + 3, Length(su) - z - 2);
if c = 'B' then
begin
s := DecodeBase64(su);
s := CharsetConversion(s, ichar, CP);
end;
if c = 'Q' then
begin
s := '';
for n := 1 to Length(su) do
if su[n] = '_' then
s := s + ' '
else
s := s + su[n];
s := DecodeQuotedPrintable(s);
s := CharsetConversion(s, ichar, CP);
end;
end;
Result := Result + s;
x := Pos('=?', v);
y := SearchEndInline(v, x);
end;
Result := Result + v;
end;
{==============================================================================}
function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string;
var
s, s1, e: string;
n: Integer;
begin
s := CharsetConversion(Value, CP, MimeP);
s := EncodeSafeQuotedPrintable(s);
e := GetIdFromCP(MimeP);
s1 := '';
Result := '';
for n := 1 to Length(s) do
if s[n] = ' ' then
begin
// s1 := s1 + '=20';
s1 := s1 + '_';
if Length(s1) > 32 then
begin
if Result <> '' then
Result := Result + ' ';
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
s1 := '';
end;
end
else
s1 := s1 + s[n];
if s1 <> '' then
begin
if Result <> '' then
Result := Result + ' ';
Result := Result + '=?' + e + '?Q?' + s1 + '?=';
end;
end;
{==============================================================================}
function NeedInline(const Value: AnsiString): boolean;
var
n: Integer;
begin
Result := False;
for n := 1 to Length(Value) do
if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then
begin
Result := True;
Break;
end;
end;
{==============================================================================}
function InlineCodeEx(const Value: string; FromCP: TMimeChar): string;
var
c: TMimeChar;
begin
if NeedInline(Value) then
begin
c := IdealCharsetCoding(Value, FromCP, IdealCharsets);
Result := InlineEncode(Value, FromCP, c);
end
else
Result := Value;
end;
{==============================================================================}
function InlineCode(const Value: string): string;
begin
Result := InlineCodeEx(Value, GetCurCP);
end;
{==============================================================================}
function InlineEmailEx(const Value: string; FromCP: TMimeChar): string;
var
sd, se: string;
begin
sd := GetEmailDesc(Value);
se := GetEmailAddr(Value);
if sd = '' then
Result := se
else
Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>';
end;
{==============================================================================}
function InlineEmail(const Value: string): string;
begin
Result := InlineEmailEx(Value, GetCurCP);
end;
end.

851
synapse/mimemess.pas Normal file
View File

@ -0,0 +1,851 @@
{==============================================================================|
| Project : Ararat Synapse | 002.006.000 |
|==============================================================================|
| Content: MIME message object |
|==============================================================================|
| Copyright (c)1999-2012, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2012. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM From distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(MIME message handling)
Classes for easy handling with e-mail message.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$M+}
unit mimemess;
interface
uses
Classes, SysUtils,
mimepart, synachar, synautil, mimeinln;
type
{:Possible values for message priority}
TMessPriority = (MP_unknown, MP_low, MP_normal, MP_high);
{:@abstract(Object for basic e-mail header fields.)}
TMessHeader = class(TObject)
private
FFrom: string;
FToList: TStringList;
FCCList: TStringList;
FSubject: string;
FOrganization: string;
FCustomHeaders: TStringList;
FDate: TDateTime;
FXMailer: string;
FCharsetCode: TMimeChar;
FReplyTo: string;
FMessageID: string;
FPriority: TMessPriority;
Fpri: TMessPriority;
Fxpri: TMessPriority;
Fxmspri: TMessPriority;
protected
function ParsePriority(value: string): TMessPriority;
function DecodeHeader(value: string): boolean; virtual;
public
constructor Create; virtual;
destructor Destroy; override;
{:Clears all data fields.}
procedure Clear; virtual;
{Add headers from from this object to Value.}
procedure EncodeHeaders(const Value: TStrings); virtual;
{:Parse header from Value to this object.}
procedure DecodeHeaders(const Value: TStrings);
{:Try find specific header in CustomHeader. Search is case insensitive.
This is good for reading any non-parsed header.}
function FindHeader(Value: string): string;
{:Try find specific headers in CustomHeader. This metod is for repeatly used
headers like 'received' header, etc. Search is case insensitive.
This is good for reading ano non-parsed header.}
procedure FindHeaderList(Value: string; const HeaderList: TStrings);
published
{:Sender of message.}
property From: string read FFrom Write FFrom;
{:Stringlist with receivers of message. (one per line)}
property ToList: TStringList read FToList;
{:Stringlist with Carbon Copy receivers of message. (one per line)}
property CCList: TStringList read FCCList;
{:Subject of message.}
property Subject: string read FSubject Write FSubject;
{:Organization string.}
property Organization: string read FOrganization Write FOrganization;
{:After decoding contains all headers lines witch not have parsed to any
other structures in this object. It mean: this conatins all other headers
except:
X-MAILER, FROM, SUBJECT, ORGANIZATION, TO, CC, DATE, MIME-VERSION,
CONTENT-TYPE, CONTENT-DESCRIPTION, CONTENT-DISPOSITION, CONTENT-ID,
CONTENT-TRANSFER-ENCODING, REPLY-TO, MESSAGE-ID, X-MSMAIL-PRIORITY,
X-PRIORITY, PRIORITY
When you encode headers, all this lines is added as headers. Be carefull
for duplicites!}
property CustomHeaders: TStringList read FCustomHeaders;
{:Date and time of message.}
property Date: TDateTime read FDate Write FDate;
{:Mailer identification.}
property XMailer: string read FXMailer Write FXMailer;
{:Address for replies}
property ReplyTo: string read FReplyTo Write FReplyTo;
{:message indetifier}
property MessageID: string read FMessageID Write FMessageID;
{:message priority}
property Priority: TMessPriority read FPriority Write FPriority;
{:Specify base charset. By default is used system charset.}
property CharsetCode: TMimeChar read FCharsetCode Write FCharsetCode;
end;
TMessHeaderClass = class of TMessHeader;
{:@abstract(Object for handling of e-mail message.)}
TMimeMess = class(TObject)
private
FMessagePart: TMimePart;
FLines: TStringList;
FHeader: TMessHeader;
public
constructor Create;
{:create this object and assign your own descendant of @link(TMessHeader)
object to @link(header) property. So, you can create your own message
headers parser and use it by this object.}
constructor CreateAltHeaders(HeadClass: TMessHeaderClass);
destructor Destroy; override;
{:Reset component to default state.}
procedure Clear; virtual;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then one subpart,
you must have PartParent of multipart type!}
function AddPart(const PartParent: TMimePart): TMimePart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
This part is marked as multipart with secondary MIME type specified by
MultipartType parameter. (typical value is 'mixed')
This part can be used as PartParent for another parts (include next
multipart). If you need only one part, then you not need Multipart part.}
function AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to text part and set all necessary
properties. Content of part is readed from value stringlist.}
function AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to text part and set all necessary
properties. Content of part is readed from value stringlist. You can select
your charset and your encoding type. If Raw is @true, then it not doing
charset conversion!}
function AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to text part to HTML type and set all
necessary properties. Content of HTML part is readed from Value stringlist.}
function AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartText), but content is readed from file}
function AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartHTML), but content is readed from file}
function AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart,
you must have PartParent of multipart type!
After creation of part set type to binary and set all necessary properties.
MIME primary and secondary types defined automaticly by filename extension.
Content of binary part is readed from Stream. This binary part is encoded
as file attachment.}
function AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartBinary), but content is readed from file}
function AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to binary and set all necessary properties.
MIME primary and secondary types defined automaticly by filename extension.
Content of binary part is readed from Stream.
This binary part is encoded as inline data with given Conten ID (cid).
Content ID can be used as reference ID in HTML source in HTML part.}
function AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartHTMLBinary), but content is readed from file}
function AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
{:Add MIME part as subpart of PartParent. If you need set root MIME part,
then set as PartParent @NIL value. If you need set more then 1 subpart, you
must have PartParent of multipart type!
After creation of part set type to message and set all necessary properties.
MIME primary and secondary types are setted to 'message/rfc822'.
Content of raw RFC-822 message is readed from Stream.}
function AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
{:Same as @link(AddPartMess), but content is readed from file}
function AddPartMessFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
{:Compose message from @link(MessagePart) to @link(Lines). Headers from
@link(Header) object is added also.}
procedure EncodeMessage;
{:Decode message from @link(Lines) to @link(MessagePart). Massage headers
are parsed into @link(Header) object.}
procedure DecodeMessage;
{pf}
{: HTTP message is received by @link(THTTPSend) component in two parts:
headers are stored in @link(THTTPSend.Headers) and a body in memory stream
@link(THTTPSend.Document).
On the top of it, HTTP connections are always 8-bit, hence data are
transferred in native format i.e. no transfer encoding is applied.
This method operates the similiar way and produces the same
result as @link(DecodeMessage).
}
procedure DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream);
{/pf}
published
{:@link(TMimePart) object with decoded MIME message. This object can handle
any number of nested @link(TMimePart) objects itself. It is used for handle
any tree of MIME subparts.}
property MessagePart: TMimePart read FMessagePart;
{:Raw MIME encoded message.}
property Lines: TStringList read FLines;
{:Object for e-mail header fields. This object is created automaticly.
Do not free this object!}
property Header: TMessHeader read FHeader;
end;
implementation
{==============================================================================}
constructor TMessHeader.Create;
begin
inherited Create;
FToList := TStringList.Create;
FCCList := TStringList.Create;
FCustomHeaders := TStringList.Create;
FCharsetCode := GetCurCP;
end;
destructor TMessHeader.Destroy;
begin
FCustomHeaders.Free;
FCCList.Free;
FToList.Free;
inherited Destroy;
end;
{==============================================================================}
procedure TMessHeader.Clear;
begin
FFrom := '';
FToList.Clear;
FCCList.Clear;
FSubject := '';
FOrganization := '';
FCustomHeaders.Clear;
FDate := 0;
FXMailer := '';
FReplyTo := '';
FMessageID := '';
FPriority := MP_unknown;
end;
procedure TMessHeader.EncodeHeaders(const Value: TStrings);
var
n: Integer;
s: string;
begin
if FDate = 0 then
FDate := Now;
for n := FCustomHeaders.Count - 1 downto 0 do
if FCustomHeaders[n] <> '' then
Value.Insert(0, FCustomHeaders[n]);
if FPriority <> MP_unknown then
case FPriority of
MP_high:
begin
Value.Insert(0, 'X-MSMAIL-Priority: High');
Value.Insert(0, 'X-Priority: 1');
Value.Insert(0, 'Priority: urgent');
end;
MP_low:
begin
Value.Insert(0, 'X-MSMAIL-Priority: low');
Value.Insert(0, 'X-Priority: 5');
Value.Insert(0, 'Priority: non-urgent');
end;
end;
if FReplyTo <> '' then
Value.Insert(0, 'Reply-To: ' + GetEmailAddr(FReplyTo));
if FMessageID <> '' then
Value.Insert(0, 'Message-ID: <' + trim(FMessageID) + '>');
if FXMailer = '' then
Value.Insert(0, 'X-mailer: Synapse - Pascal TCP/IP library by Lukas Gebauer')
else
Value.Insert(0, 'X-mailer: ' + FXMailer);
Value.Insert(0, 'MIME-Version: 1.0 (produced by Synapse)');
if FOrganization <> '' then
Value.Insert(0, 'Organization: ' + InlineCodeEx(FOrganization, FCharsetCode));
s := '';
for n := 0 to FCCList.Count - 1 do
if s = '' then
s := InlineEmailEx(FCCList[n], FCharsetCode)
else
s := s + ', ' + InlineEmailEx(FCCList[n], FCharsetCode);
if s <> '' then
Value.Insert(0, 'CC: ' + s);
Value.Insert(0, 'Date: ' + Rfc822DateTime(FDate));
if FSubject <> '' then
Value.Insert(0, 'Subject: ' + InlineCodeEx(FSubject, FCharsetCode));
s := '';
for n := 0 to FToList.Count - 1 do
if s = '' then
s := InlineEmailEx(FToList[n], FCharsetCode)
else
s := s + ', ' + InlineEmailEx(FToList[n], FCharsetCode);
if s <> '' then
Value.Insert(0, 'To: ' + s);
Value.Insert(0, 'From: ' + InlineEmailEx(FFrom, FCharsetCode));
end;
function TMessHeader.ParsePriority(value: string): TMessPriority;
var
s: string;
x: integer;
begin
Result := MP_unknown;
s := Trim(separateright(value, ':'));
s := Separateleft(s, ' ');
x := StrToIntDef(s, -1);
if x >= 0 then
case x of
1, 2:
Result := MP_High;
3:
Result := MP_Normal;
4, 5:
Result := MP_Low;
end
else
begin
s := lowercase(s);
if (s = 'urgent') or (s = 'high') or (s = 'highest') then
Result := MP_High;
if (s = 'normal') or (s = 'medium') then
Result := MP_Normal;
if (s = 'low') or (s = 'lowest')
or (s = 'no-priority') or (s = 'non-urgent') then
Result := MP_Low;
end;
end;
function TMessHeader.DecodeHeader(value: string): boolean;
var
s, t: string;
cp: TMimeChar;
begin
Result := True;
cp := FCharsetCode;
s := uppercase(value);
if Pos('X-MAILER:', s) = 1 then
begin
FXMailer := Trim(SeparateRight(Value, ':'));
Exit;
end;
if Pos('FROM:', s) = 1 then
begin
FFrom := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('SUBJECT:', s) = 1 then
begin
FSubject := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('ORGANIZATION:', s) = 1 then
begin
FOrganization := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('TO:', s) = 1 then
begin
s := Trim(SeparateRight(Value, ':'));
repeat
t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
if t <> '' then
FToList.Add(t);
until s = '';
Exit;
end;
if Pos('CC:', s) = 1 then
begin
s := Trim(SeparateRight(Value, ':'));
repeat
t := InlineDecode(Trim(FetchEx(s, ',', '"')), cp);
if t <> '' then
FCCList.Add(t);
until s = '';
Exit;
end;
if Pos('DATE:', s) = 1 then
begin
FDate := DecodeRfcDateTime(Trim(SeparateRight(Value, ':')));
Exit;
end;
if Pos('REPLY-TO:', s) = 1 then
begin
FReplyTo := InlineDecode(Trim(SeparateRight(Value, ':')), cp);
Exit;
end;
if Pos('MESSAGE-ID:', s) = 1 then
begin
FMessageID := GetEmailAddr(Trim(SeparateRight(Value, ':')));
Exit;
end;
if Pos('PRIORITY:', s) = 1 then
begin
FPri := ParsePriority(value);
Exit;
end;
if Pos('X-PRIORITY:', s) = 1 then
begin
FXPri := ParsePriority(value);
Exit;
end;
if Pos('X-MSMAIL-PRIORITY:', s) = 1 then
begin
FXmsPri := ParsePriority(value);
Exit;
end;
if Pos('MIME-VERSION:', s) = 1 then
Exit;
if Pos('CONTENT-TYPE:', s) = 1 then
Exit;
if Pos('CONTENT-DESCRIPTION:', s) = 1 then
Exit;
if Pos('CONTENT-DISPOSITION:', s) = 1 then
Exit;
if Pos('CONTENT-ID:', s) = 1 then
Exit;
if Pos('CONTENT-TRANSFER-ENCODING:', s) = 1 then
Exit;
Result := False;
end;
procedure TMessHeader.DecodeHeaders(const Value: TStrings);
var
s: string;
x: Integer;
begin
Clear;
Fpri := MP_unknown;
Fxpri := MP_unknown;
Fxmspri := MP_unknown;
x := 0;
while Value.Count > x do
begin
s := NormalizeHeader(Value, x);
if s = '' then
Break;
if not DecodeHeader(s) then
FCustomHeaders.Add(s);
end;
if Fpri <> MP_unknown then
FPriority := Fpri
else
if Fxpri <> MP_unknown then
FPriority := Fxpri
else
if Fxmspri <> MP_unknown then
FPriority := Fxmspri
end;
function TMessHeader.FindHeader(Value: string): string;
var
n: integer;
begin
Result := '';
for n := 0 to FCustomHeaders.Count - 1 do
if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
begin
Result := Trim(SeparateRight(FCustomHeaders[n], ':'));
break;
end;
end;
procedure TMessHeader.FindHeaderList(Value: string; const HeaderList: TStrings);
var
n: integer;
begin
HeaderList.Clear;
for n := 0 to FCustomHeaders.Count - 1 do
if Pos(UpperCase(Value), UpperCase(FCustomHeaders[n])) = 1 then
begin
HeaderList.Add(Trim(SeparateRight(FCustomHeaders[n], ':')));
end;
end;
{==============================================================================}
constructor TMimeMess.Create;
begin
CreateAltHeaders(TMessHeader);
end;
constructor TMimeMess.CreateAltHeaders(HeadClass: TMessHeaderClass);
begin
inherited Create;
FMessagePart := TMimePart.Create;
FLines := TStringList.Create;
FHeader := HeadClass.Create;
end;
destructor TMimeMess.Destroy;
begin
FMessagePart.Free;
FHeader.Free;
FLines.Free;
inherited Destroy;
end;
{==============================================================================}
procedure TMimeMess.Clear;
begin
FMessagePart.Clear;
FLines.Clear;
FHeader.Clear;
end;
{==============================================================================}
function TMimeMess.AddPart(const PartParent: TMimePart): TMimePart;
begin
if PartParent = nil then
Result := FMessagePart
else
Result := PartParent.AddSubPart;
Result.Clear;
end;
{==============================================================================}
function TMimeMess.AddPartMultipart(const MultipartType: String; const PartParent: TMimePart): TMimePart;
begin
Result := AddPart(PartParent);
with Result do
begin
Primary := 'Multipart';
Secondary := MultipartType;
Description := 'Multipart message';
Boundary := GenerateBoundary;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartText(const Value: TStrings; const PartParent: TMimePart): TMimepart;
begin
Result := AddPart(PartParent);
with Result do
begin
Value.SaveToStream(DecodedLines);
Primary := 'text';
Secondary := 'plain';
Description := 'Message text';
Disposition := 'inline';
CharsetCode := IdealCharsetCoding(Value.Text, TargetCharset, IdealCharsets);
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartTextEx(const Value: TStrings; const PartParent: TMimePart;
PartCharset: TMimeChar; Raw: Boolean; PartEncoding: TMimeEncoding): TMimepart;
begin
Result := AddPart(PartParent);
with Result do
begin
Value.SaveToStream(DecodedLines);
Primary := 'text';
Secondary := 'plain';
Description := 'Message text';
Disposition := 'inline';
CharsetCode := PartCharset;
EncodingCode := PartEncoding;
ConvertCharset := not Raw;
EncodePart;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartHTML(const Value: TStrings; const PartParent: TMimePart): TMimepart;
begin
Result := AddPart(PartParent);
with Result do
begin
Value.SaveToStream(DecodedLines);
Primary := 'text';
Secondary := 'html';
Description := 'HTML text';
Disposition := 'inline';
CharsetCode := UTF_8;
EncodingCode := ME_QUOTED_PRINTABLE;
EncodePart;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartTextFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
tmp: TStrings;
begin
tmp := TStringList.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartText(tmp, PartParent);
Finally
tmp.Free;
end;
end;
function TMimeMess.AddPartHTMLFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
tmp: TStrings;
begin
tmp := TStringList.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartHTML(tmp, PartParent);
Finally
tmp.Free;
end;
end;
function TMimeMess.AddPartBinary(const Stream: TStream; const FileName: string; const PartParent: TMimePart): TMimepart;
begin
Result := AddPart(PartParent);
Result.DecodedLines.LoadFromStream(Stream);
Result.MimeTypeFromExt(FileName);
Result.Description := 'Attached file: ' + FileName;
Result.Disposition := 'attachment';
Result.FileName := FileName;
Result.EncodingCode := ME_BASE64;
Result.EncodePart;
Result.EncodePartHeader;
end;
function TMimeMess.AddPartBinaryFromFile(const FileName: string; const PartParent: TMimePart): TMimepart;
var
tmp: TMemoryStream;
begin
tmp := TMemoryStream.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartBinary(tmp, ExtractFileName(FileName), PartParent);
finally
tmp.Free;
end;
end;
function TMimeMess.AddPartHTMLBinary(const Stream: TStream; const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
begin
Result := AddPart(PartParent);
Result.DecodedLines.LoadFromStream(Stream);
Result.MimeTypeFromExt(FileName);
Result.Description := 'Included file: ' + FileName;
Result.Disposition := 'inline';
Result.ContentID := Cid;
Result.FileName := FileName;
Result.EncodingCode := ME_BASE64;
Result.EncodePart;
Result.EncodePartHeader;
end;
function TMimeMess.AddPartHTMLBinaryFromFile(const FileName, Cid: string; const PartParent: TMimePart): TMimepart;
var
tmp: TMemoryStream;
begin
tmp := TMemoryStream.Create;
try
tmp.LoadFromFile(FileName);
Result :=AddPartHTMLBinary(tmp, ExtractFileName(FileName), Cid, PartParent);
finally
tmp.Free;
end;
end;
function TMimeMess.AddPartMess(const Value: TStrings; const PartParent: TMimePart): TMimepart;
var
part: Tmimepart;
begin
Result := AddPart(PartParent);
part := AddPart(result);
part.lines.addstrings(Value);
part.DecomposeParts;
with Result do
begin
Primary := 'message';
Secondary := 'rfc822';
Description := 'E-mail Message';
EncodePart;
EncodePartHeader;
end;
end;
function TMimeMess.AddPartMessFromFile(const FileName: String; const PartParent: TMimePart): TMimepart;
var
tmp: TStrings;
begin
tmp := TStringList.Create;
try
tmp.LoadFromFile(FileName);
Result := AddPartMess(tmp, PartParent);
Finally
tmp.Free;
end;
end;
{==============================================================================}
procedure TMimeMess.EncodeMessage;
var
l: TStringList;
x: integer;
begin
//merge headers from THeaders and header field from MessagePart
l := TStringList.Create;
try
FHeader.EncodeHeaders(l);
x := IndexByBegin('CONTENT-TYPE', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-DESCRIPTION', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-DISPOSITION', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-ID', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
x := IndexByBegin('CONTENT-TRANSFER-ENCODING', FMessagePart.Headers);
if x >= 0 then
l.add(FMessagePart.Headers[x]);
FMessagePart.Headers.Assign(l);
finally
l.Free;
end;
FMessagePart.ComposeParts;
FLines.Assign(FMessagePart.Lines);
end;
{==============================================================================}
procedure TMimeMess.DecodeMessage;
begin
FHeader.Clear;
FHeader.DecodeHeaders(FLines);
FMessagePart.Lines.Assign(FLines);
FMessagePart.DecomposeParts;
end;
{pf}
procedure TMimeMess.DecodeMessageBinary(AHeader:TStrings; AData:TMemoryStream);
begin
FHeader.Clear;
FLines.Clear;
FLines.Assign(AHeader);
FHeader.DecodeHeaders(FLines);
FMessagePart.DecomposePartsBinary(AHeader,PANSIChar(AData.Memory),PANSIChar(AData.Memory)+AData.Size);
end;
{/pf}
end.

1227
synapse/mimepart.pas Normal file
View File

File diff suppressed because it is too large Load Diff

483
synapse/nntpsend.pas Normal file
View File

@ -0,0 +1,483 @@
{==============================================================================|
| Project : Ararat Synapse | 001.005.003 |
|==============================================================================|
| Content: NNTP client |
|==============================================================================|
| Copyright (c)1999-2011, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2011. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(NNTP client)
NNTP (network news transfer protocol)
Used RFC: RFC-977, RFC-2980
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}
unit nntpsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cNNTPProtocol = '119';
type
{:abstract(Implementation of Network News Transfer Protocol.
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TNNTPSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FResultCode: Integer;
FResultString: string;
FData: TStringList;
FDataToSend: TStringList;
FAutoTLS: Boolean;
FFullSSL: Boolean;
FNNTPcap: TStringList;
function ReadResult: Integer;
function ReadData: boolean;
function SendData: boolean;
function Connect: Boolean;
public
constructor Create;
destructor Destroy; override;
{:Connects to NNTP server and begin session.}
function Login: Boolean;
{:Logout from NNTP server and terminate session.}
function Logout: Boolean;
{:By this you can call any NNTP command.}
function DoCommand(const Command: string): boolean;
{:by this you can call any NNTP command. This variant is used for commands
for download information from server.}
function DoCommandRead(const Command: string): boolean;
{:by this you can call any NNTP command. This variant is used for commands
for upload information to server.}
function DoCommandWrite(const Command: string): boolean;
{:Download full message to @link(data) property. Value can be number of
message or message-id (in brackets).}
function GetArticle(const Value: string): Boolean;
{:Download only body of message to @link(data) property. Value can be number
of message or message-id (in brackets).}
function GetBody(const Value: string): Boolean;
{:Download only headers of message to @link(data) property. Value can be
number of message or message-id (in brackets).}
function GetHead(const Value: string): Boolean;
{:Get message status. Value can be number of message or message-id
(in brackets).}
function GetStat(const Value: string): Boolean;
{:Select given group.}
function SelectGroup(const Value: string): Boolean;
{:Tell to server 'I have mesage with given message-ID.' If server need this
message, message is uploaded to server.}
function IHave(const MessID: string): Boolean;
{:Move message pointer to last item in group.}
function GotoLast: Boolean;
{:Move message pointer to next item in group.}
function GotoNext: Boolean;
{:Download to @link(data) property list of all groups on NNTP server.}
function ListGroups: Boolean;
{:Download to @link(data) property list of all groups created after given time.}
function ListNewGroups(Since: TDateTime): Boolean;
{:Download to @link(data) property list of message-ids in given group since
given time.}
function NewArticles(const Group: string; Since: TDateTime): Boolean;
{:Upload new article to server. (for new messages by you)}
function PostArticle: Boolean;
{:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP
server'.}
function SwitchToSlave: Boolean;
{:Call NNTP XOVER command.}
function Xover(xoStart, xoEnd: string): boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:Try to find given capability in extension list. This list is getted after
successful login to NNTP server. If extension capability is not found,
then return is empty string.}
function FindCap(const Value: string): string;
{:Try get list of server extensions. List is returned in @link(data) property.}
function ListExtensions: Boolean;
published
{:Result code number of last operation.}
property ResultCode: Integer read FResultCode;
{:String description of last result code from NNTP server.}
property ResultString: string read FResultString;
{:Readed data. (message, etc.)}
property Data: TStringList read FData;
{:If is set to @true, then upgrade to SSL/TLS mode after login if remote
server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
end;
implementation
constructor TNNTPSend.Create;
begin
inherited Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FData := TStringList.Create;
FDataToSend := TStringList.Create;
FNNTPcap := TStringList.Create;
FSock.ConvertLineEnd := True;
FTimeout := 60000;
FTargetPort := cNNTPProtocol;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TNNTPSend.Destroy;
begin
FSock.Free;
FDataToSend.Free;
FData.Free;
FNNTPcap.Free;
inherited Destroy;
end;
function TNNTPSend.ReadResult: Integer;
var
s: string;
begin
Result := 0;
FData.Clear;
s := FSock.RecvString(FTimeout);
FResultString := Copy(s, 5, Length(s) - 4);
if FSock.LastError <> 0 then
Exit;
if Length(s) >= 3 then
Result := StrToIntDef(Copy(s, 1, 3), 0);
FResultCode := Result;
end;
function TNNTPSend.ReadData: boolean;
var
s: string;
begin
repeat
s := FSock.RecvString(FTimeout);
if s = '.' then
break;
if (s <> '') and (s[1] = '.') then
s := Copy(s, 2, Length(s) - 1);
FData.Add(s);
until FSock.LastError <> 0;
Result := FSock.LastError = 0;
end;
function TNNTPSend.SendData: boolean;
var
s: string;
n: integer;
begin
for n := 0 to FDataToSend.Count - 1 do
begin
s := FDataToSend[n];
if (s <> '') and (s[1] = '.') then
s := s + '.';
FSock.SendString(s + CRLF);
if FSock.LastError <> 0 then
break;
end;
if FDataToSend.Count = 0 then
FSock.SendString(CRLF);
if FSock.LastError = 0 then
FSock.SendString('.' + CRLF);
FDataToSend.Clear;
Result := FSock.LastError = 0;
end;
function TNNTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TNNTPSend.Login: Boolean;
begin
Result := False;
FNNTPcap.Clear;
if not Connect then
Exit;
Result := (ReadResult div 100) = 2;
if Result then
begin
ListExtensions;
FNNTPcap.Assign(Fdata);
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
Result := StartTLS;
end;
if (FUsername <> '') and Result then
begin
FSock.SendString('AUTHINFO USER ' + FUsername + CRLF);
if (ReadResult div 100) = 3 then
begin
FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF);
Result := (ReadResult div 100) = 2;
end;
end;
end;
function TNNTPSend.Logout: Boolean;
begin
FSock.SendString('QUIT' + CRLF);
Result := (ReadResult div 100) = 2;
FSock.CloseSocket;
end;
function TNNTPSend.DoCommand(const Command: string): Boolean;
begin
FSock.SendString(Command + CRLF);
Result := (ReadResult div 100) = 2;
Result := Result and (FSock.LastError = 0);
end;
function TNNTPSend.DoCommandRead(const Command: string): Boolean;
begin
Result := DoCommand(Command);
if Result then
begin
Result := ReadData;
Result := Result and (FSock.LastError = 0);
end;
end;
function TNNTPSend.DoCommandWrite(const Command: string): Boolean;
var
x: integer;
begin
FDataToSend.Assign(FData);
FSock.SendString(Command + CRLF);
x := (ReadResult div 100);
if x = 3 then
begin
SendData;
x := (ReadResult div 100);
end;
Result := x = 2;
Result := Result and (FSock.LastError = 0);
end;
function TNNTPSend.GetArticle(const Value: string): Boolean;
var
s: string;
begin
s := 'ARTICLE';
if Value <> '' then
s := s + ' ' + Value;
Result := DoCommandRead(s);
end;
function TNNTPSend.GetBody(const Value: string): Boolean;
var
s: string;
begin
s := 'BODY';
if Value <> '' then
s := s + ' ' + Value;
Result := DoCommandRead(s);
end;
function TNNTPSend.GetHead(const Value: string): Boolean;
var
s: string;
begin
s := 'HEAD';
if Value <> '' then
s := s + ' ' + Value;
Result := DoCommandRead(s);
end;
function TNNTPSend.GetStat(const Value: string): Boolean;
var
s: string;
begin
s := 'STAT';
if Value <> '' then
s := s + ' ' + Value;
Result := DoCommand(s);
end;
function TNNTPSend.SelectGroup(const Value: string): Boolean;
begin
Result := DoCommand('GROUP ' + Value);
end;
function TNNTPSend.IHave(const MessID: string): Boolean;
begin
Result := DoCommandWrite('IHAVE ' + MessID);
end;
function TNNTPSend.GotoLast: Boolean;
begin
Result := DoCommand('LAST');
end;
function TNNTPSend.GotoNext: Boolean;
begin
Result := DoCommand('NEXT');
end;
function TNNTPSend.ListGroups: Boolean;
begin
Result := DoCommandRead('LIST');
end;
function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean;
begin
Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT');
end;
function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean;
begin
Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT');
end;
function TNNTPSend.PostArticle: Boolean;
begin
Result := DoCommandWrite('POST');
end;
function TNNTPSend.SwitchToSlave: Boolean;
begin
Result := DoCommand('SLAVE');
end;
function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean;
var
s: string;
begin
s := 'XOVER ' + xoStart;
if xoEnd <> xoStart then
s := s + '-' + xoEnd;
Result := DoCommandRead(s);
end;
function TNNTPSend.StartTLS: Boolean;
begin
Result := False;
if FindCap('STARTTLS') <> '' then
begin
if DoCommand('STARTTLS') then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
end;
function TNNTPSend.ListExtensions: Boolean;
begin
Result := DoCommandRead('LIST EXTENSIONS');
end;
function TNNTPSend.FindCap(const Value: string): string;
var
n: Integer;
s: string;
begin
s := UpperCase(Value);
Result := '';
for n := 0 to FNNTPcap.Count - 1 do
if Pos(s, UpperCase(FNNTPcap[n])) = 1 then
begin
Result := FNNTPcap[n];
Break;
end;
end;
{==============================================================================}
end.

720
synapse/pingsend.pas Normal file
View File

@ -0,0 +1,720 @@
{==============================================================================|
| Project : Ararat Synapse | 004.000.002 |
|==============================================================================|
| Content: PING sender |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(ICMP PING implementation.)
Allows create PING and TRACEROUTE. Or you can diagnose your network.
This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying
to use RAW sockets.
Warning: For use of RAW sockets you must have some special rights on some
systems. So, it working allways when you have administator/root rights.
Otherwise you can have problems!
Note: This unit is NOT portable to .NET!
Use native .NET classes for Ping instead.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}
{$IFDEF CIL}
Sorry, this unit is not for .NET!
{$ENDIF}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit pingsend;
interface
uses
SysUtils,
synsock, blcksock, synautil, synafpc, synaip
{$IFDEF MSWINDOWS}
, windows
{$ENDIF}
;
const
ICMP_ECHO = 8;
ICMP_ECHOREPLY = 0;
ICMP_UNREACH = 3;
ICMP_TIME_EXCEEDED = 11;
//rfc-2292
ICMP6_ECHO = 128;
ICMP6_ECHOREPLY = 129;
ICMP6_UNREACH = 1;
ICMP6_TIME_EXCEEDED = 3;
type
{:List of possible ICMP reply packet types.}
TICMPError = (
IE_NoError,
IE_Other,
IE_TTLExceed,
IE_UnreachOther,
IE_UnreachRoute,
IE_UnreachAdmin,
IE_UnreachAddr,
IE_UnreachPort
);
{:@abstract(Implementation of ICMP PING and ICMPv6 PING.)}
TPINGSend = class(TSynaClient)
private
FSock: TICMPBlockSocket;
FBuffer: Ansistring;
FSeq: Integer;
FId: Integer;
FPacketSize: Integer;
FPingTime: Integer;
FIcmpEcho: Byte;
FIcmpEchoReply: Byte;
FIcmpUnreach: Byte;
FReplyFrom: string;
FReplyType: byte;
FReplyCode: byte;
FReplyError: TICMPError;
FReplyErrorDesc: string;
FTTL: Byte;
Fsin: TVarSin;
function Checksum(Value: AnsiString): Word;
function Checksum6(Value: AnsiString): Word;
function ReadPacket: Boolean;
procedure TranslateError;
procedure TranslateErrorIpHlp(value: integer);
function InternalPing(const Host: string): Boolean;
function InternalPingIpHlp(const Host: string): Boolean;
function IsHostIP6(const Host: string): Boolean;
procedure GenErrorDesc;
public
{:Send ICMP ping to host and count @link(pingtime). If ping OK, result is
@true.}
function Ping(const Host: string): Boolean;
constructor Create;
destructor Destroy; override;
published
{:Size of PING packet. Default size is 32 bytes.}
property PacketSize: Integer read FPacketSize Write FPacketSize;
{:Time between request and reply.}
property PingTime: Integer read FPingTime;
{:From this address is sended reply for your PING request. It maybe not your
requested destination, when some error occured!}
property ReplyFrom: string read FReplyFrom;
{:ICMP type of PING reply. Each protocol using another values! For IPv4 and
IPv6 are used different values!}
property ReplyType: byte read FReplyType;
{:ICMP code of PING reply. Each protocol using another values! For IPv4 and
IPv6 are used different values! For protocol independent value look to
@link(ReplyError)}
property ReplyCode: byte read FReplyCode;
{:Return type of returned ICMP message. This value is independent on used
protocol!}
property ReplyError: TICMPError read FReplyError;
{:Return human readable description of returned packet type.}
property ReplyErrorDesc: string read FReplyErrorDesc;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TICMPBlockSocket read FSock;
{:TTL value for ICMP query}
property TTL: byte read FTTL write FTTL;
end;
{:A very useful function and example of its use would be found in the TPINGSend
object. Use it to ping to any host. If successful, returns the ping time in
milliseconds. Returns -1 if an error occurred.}
function PingHost(const Host: string): Integer;
{:A very useful function and example of its use would be found in the TPINGSend
object. Use it to TraceRoute to any host.}
function TraceRouteHost(const Host: string): string;
implementation
type
{:Record for ICMP ECHO packet header.}
TIcmpEchoHeader = packed record
i_type: Byte;
i_code: Byte;
i_checkSum: Word;
i_Id: Word;
i_seq: Word;
TimeStamp: integer;
end;
{:record used internally by TPingSend for compute checksum of ICMPv6 packet
pseudoheader.}
TICMP6Packet = packed record
in_source: TInAddr6;
in_dest: TInAddr6;
Length: integer;
free0: Byte;
free1: Byte;
free2: Byte;
proto: Byte;
end;
{$IFDEF MSWINDOWS}
const
DLLIcmpName = 'iphlpapi.dll';
type
TIP_OPTION_INFORMATION = record
TTL: Byte;
TOS: Byte;
Flags: Byte;
OptionsSize: Byte;
OptionsData: PAnsiChar;
end;
PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION;
TICMP_ECHO_REPLY = record
Address: TInAddr;
Status: integer;
RoundTripTime: integer;
DataSize: Word;
Reserved: Word;
Data: pointer;
Options: TIP_OPTION_INFORMATION;
end;
PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY;
TICMPV6_ECHO_REPLY = record
Address: TSockAddrIn6;
Status: integer;
RoundTripTime: integer;
end;
PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY;
TIcmpCreateFile = function: integer; stdcall;
TIcmpCloseHandle = function(handle: integer): boolean; stdcall;
TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer;
RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
TIcmp6CreateFile = function: integer; stdcall;
TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6;
RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
var
IcmpDllHandle: TLibHandle = 0;
IcmpHelper4: boolean = false;
IcmpHelper6: boolean = false;
IcmpCreateFile: TIcmpCreateFile = nil;
IcmpCloseHandle: TIcmpCloseHandle = nil;
IcmpSendEcho2: TIcmpSendEcho2 = nil;
Icmp6CreateFile: TIcmp6CreateFile = nil;
Icmp6SendEcho2: TIcmp6SendEcho2 = nil;
{$ENDIF}
{==============================================================================}
constructor TPINGSend.Create;
begin
inherited Create;
FSock := TICMPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 5000;
FPacketSize := 32;
FSeq := 0;
Randomize;
FTTL := 128;
end;
destructor TPINGSend.Destroy;
begin
FSock.Free;
inherited Destroy;
end;
function TPINGSend.ReadPacket: Boolean;
begin
FBuffer := FSock.RecvPacket(Ftimeout);
Result := FSock.LastError = 0;
end;
procedure TPINGSend.GenErrorDesc;
begin
case FReplyError of
IE_NoError:
FReplyErrorDesc := '';
IE_Other:
FReplyErrorDesc := 'Unknown error';
IE_TTLExceed:
FReplyErrorDesc := 'TTL Exceeded';
IE_UnreachOther:
FReplyErrorDesc := 'Unknown unreachable';
IE_UnreachRoute:
FReplyErrorDesc := 'No route to destination';
IE_UnreachAdmin:
FReplyErrorDesc := 'Administratively prohibited';
IE_UnreachAddr:
FReplyErrorDesc := 'Address unreachable';
IE_UnreachPort:
FReplyErrorDesc := 'Port unreachable';
end;
end;
function TPINGSend.IsHostIP6(const Host: string): Boolean;
var
f: integer;
begin
f := AF_UNSPEC;
if IsIp(Host) then
f := AF_INET
else
if IsIp6(Host) then
f := AF_INET6;
synsock.SetVarSin(Fsin, host, '0', f,
IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4);
result := Fsin.sin_family = AF_INET6;
end;
function TPINGSend.Ping(const Host: string): Boolean;
var
b: boolean;
begin
FPingTime := -1;
FReplyFrom := '';
FReplyType := 0;
FReplyCode := 0;
FReplyError := IE_Other;
GenErrorDesc;
FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
{$IFDEF MSWINDOWS}
b := IsHostIP6(host);
if not(b) and IcmpHelper4 then
result := InternalPingIpHlp(host)
else
if b and IcmpHelper6 then
result := InternalPingIpHlp(host)
else
result := InternalPing(host);
{$ELSE}
result := InternalPing(host);
{$ENDIF}
end;
function TPINGSend.InternalPing(const Host: string): Boolean;
var
IPHeadPtr: ^TIPHeader;
IpHdrLen: Integer;
IcmpEchoHeaderPtr: ^TICMPEchoHeader;
t: Boolean;
x: cardinal;
IcmpReqHead: string;
begin
Result := False;
FSock.TTL := FTTL;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(Host, '0');
if FSock.LastError <> 0 then
Exit;
FSock.SizeRecvBuffer := 60 * 1024;
if FSock.IP6used then
begin
FIcmpEcho := ICMP6_ECHO;
FIcmpEchoReply := ICMP6_ECHOREPLY;
FIcmpUnreach := ICMP6_UNREACH;
end
else
begin
FIcmpEcho := ICMP_ECHO;
FIcmpEchoReply := ICMP_ECHOREPLY;
FIcmpUnreach := ICMP_UNREACH;
end;
IcmpEchoHeaderPtr := Pointer(FBuffer);
with IcmpEchoHeaderPtr^ do
begin
i_type := FIcmpEcho;
i_code := 0;
i_CheckSum := 0;
FId := System.Random(32767);
i_Id := FId;
TimeStamp := GetTick;
Inc(FSeq);
i_Seq := FSeq;
if fSock.IP6used then
i_CheckSum := CheckSum6(FBuffer)
else
i_CheckSum := CheckSum(FBuffer);
end;
FSock.SendString(FBuffer);
// remember first 8 bytes of ICMP packet
IcmpReqHead := Copy(FBuffer, 1, 8);
x := GetTick;
repeat
t := ReadPacket;
if not t then
break;
if fSock.IP6used then
begin
{$IFNDEF MSWINDOWS}
IcmpEchoHeaderPtr := Pointer(FBuffer);
{$ELSE}
//WinXP SP1 with networking update doing this think by another way ;-O
// FBuffer := StringOfChar(#0, 4) + FBuffer;
IcmpEchoHeaderPtr := Pointer(FBuffer);
// IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply;
{$ENDIF}
end
else
begin
IPHeadPtr := Pointer(FBuffer);
IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
end;
//check for timeout
if TickDelta(x, GetTick) > FTimeout then
begin
t := false;
Break;
end;
//it discard sometimes possible 'echoes' of previosly sended packet
//or other unwanted ICMP packets...
until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho)
and ((IcmpEchoHeaderPtr^.i_id = FId)
or (Pos(IcmpReqHead, FBuffer) > 0));
if t then
begin
FPingTime := TickDelta(x, GetTick);
FReplyFrom := FSock.GetRemoteSinIP;
FReplyType := IcmpEchoHeaderPtr^.i_type;
FReplyCode := IcmpEchoHeaderPtr^.i_code;
TranslateError;
Result := True;
end;
end;
function TPINGSend.Checksum(Value: AnsiString): Word;
var
CkSum: integer;
Num, Remain: Integer;
n, i: Integer;
begin
Num := Length(Value) div 2;
Remain := Length(Value) mod 2;
CkSum := 0;
i := 1;
for n := 0 to Num - 1 do
begin
CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i));
inc(i, 2);
end;
if Remain <> 0 then
CkSum := CkSum + Ord(Value[Length(Value)]);
CkSum := (CkSum shr 16) + (CkSum and $FFFF);
CkSum := CkSum + (CkSum shr 16);
Result := Word(not CkSum);
end;
function TPINGSend.Checksum6(Value: AnsiString): Word;
const
IOC_OUT = $40000000;
IOC_IN = $80000000;
IOC_INOUT = (IOC_IN or IOC_OUT);
IOC_WS2 = $08000000;
SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT;
var
ICMP6Ptr: ^TICMP6Packet;
s: AnsiString;
b: integer;
ip6: TSockAddrIn6;
x: integer;
begin
Result := 0;
{$IFDEF MSWINDOWS}
s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value;
ICMP6Ptr := Pointer(s);
x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY,
@FSock.RemoteSin, SizeOf(FSock.RemoteSin),
@ip6, SizeOf(ip6), @b, nil, nil);
if x <> -1 then
ICMP6Ptr^.in_dest := ip6.sin6_addr
else
ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr;
ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr;
ICMP6Ptr^.Length := synsock.htonl(Length(Value));
ICMP6Ptr^.proto := IPPROTO_ICMPV6;
Result := Checksum(s);
{$ENDIF}
end;
procedure TPINGSend.TranslateError;
begin
if fSock.IP6used then
begin
case FReplyType of
ICMP6_ECHOREPLY:
FReplyError := IE_NoError;
ICMP6_TIME_EXCEEDED:
FReplyError := IE_TTLExceed;
ICMP6_UNREACH:
case FReplyCode of
0:
FReplyError := IE_UnreachRoute;
3:
FReplyError := IE_UnreachAddr;
4:
FReplyError := IE_UnreachPort;
1:
FReplyError := IE_UnreachAdmin;
else
FReplyError := IE_UnreachOther;
end;
else
FReplyError := IE_Other;
end;
end
else
begin
case FReplyType of
ICMP_ECHOREPLY:
FReplyError := IE_NoError;
ICMP_TIME_EXCEEDED:
FReplyError := IE_TTLExceed;
ICMP_UNREACH:
case FReplyCode of
0:
FReplyError := IE_UnreachRoute;
1:
FReplyError := IE_UnreachAddr;
3:
FReplyError := IE_UnreachPort;
13:
FReplyError := IE_UnreachAdmin;
else
FReplyError := IE_UnreachOther;
end;
else
FReplyError := IE_Other;
end;
end;
GenErrorDesc;
end;
procedure TPINGSend.TranslateErrorIpHlp(value: integer);
begin
case value of
11000, 0:
FReplyError := IE_NoError;
11013:
FReplyError := IE_TTLExceed;
11002:
FReplyError := IE_UnreachRoute;
11003:
FReplyError := IE_UnreachAddr;
11005:
FReplyError := IE_UnreachPort;
11004:
FReplyError := IE_UnreachAdmin;
else
FReplyError := IE_Other;
end;
GenErrorDesc;
end;
function TPINGSend.InternalPingIpHlp(const Host: string): Boolean;
{$IFDEF MSWINDOWS}
var
PingIp6: boolean;
PingHandle: integer;
r: integer;
ipo: TIP_OPTION_INFORMATION;
RBuff: Ansistring;
ip4reply: PICMP_ECHO_REPLY;
ip6reply: PICMPV6_ECHO_REPLY;
ip6: TSockAddrIn6;
begin
Result := False;
PingIp6 := Fsin.sin_family = AF_INET6;
if pingIp6 then
PingHandle := Icmp6CreateFile
else
PingHandle := IcmpCreateFile;
if PingHandle <> -1 then
begin
try
ipo.TTL := FTTL;
ipo.TOS := 0;
ipo.Flags := 0;
ipo.OptionsSize := 0;
ipo.OptionsData := nil;
setlength(RBuff, 4096);
if pingIp6 then
begin
FillChar(ip6, sizeof(ip6), 0);
r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin,
PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout);
if r > 0 then
begin
RBuff := #0 + #0 + RBuff;
ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff));
FPingTime := ip6reply^.RoundTripTime;
ip6reply^.Address.sin6_family := AF_INET6;
FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address));
TranslateErrorIpHlp(ip6reply^.Status);
Result := True;
end;
end
else
begin
r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr,
PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(RBuff), length(RBuff), FTimeout);
if r > 0 then
begin
ip4reply := PICMP_ECHO_REPLY(pointer(RBuff));
FPingTime := ip4reply^.RoundTripTime;
FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr));
TranslateErrorIpHlp(ip4reply^.Status);
Result := True;
end;
end
finally
IcmpCloseHandle(PingHandle);
end;
end;
end;
{$ELSE}
begin
result := false;
end;
{$ENDIF}
{==============================================================================}
function PingHost(const Host: string): Integer;
begin
with TPINGSend.Create do
try
Result := -1;
if Ping(Host) then
if ReplyError = IE_NoError then
Result := PingTime;
finally
Free;
end;
end;
function TraceRouteHost(const Host: string): string;
var
Ping: TPingSend;
ttl : byte;
begin
Result := '';
Ping := TPINGSend.Create;
try
ttl := 1;
repeat
ping.TTL := ttl;
inc(ttl);
if ttl > 30 then
Break;
if not ping.Ping(Host) then
begin
Result := Result + cAnyHost+ ' Timeout' + CRLF;
continue;
end;
if (ping.ReplyError <> IE_NoError)
and (ping.ReplyError <> IE_TTLExceed) then
begin
Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF;
break;
end;
Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF;
until ping.ReplyError = IE_NoError;
finally
Ping.Free;
end;
end;
{$IFDEF MSWINDOWS}
initialization
begin
IcmpHelper4 := false;
IcmpHelper6 := false;
IcmpDllHandle := LoadLibrary(DLLIcmpName);
if IcmpDllHandle <> 0 then
begin
IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile');
IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle');
IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2');
Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile');
Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2');
IcmpHelper4 := assigned(IcmpCreateFile)
and assigned(IcmpCloseHandle)
and assigned(IcmpSendEcho2);
IcmpHelper6 := assigned(Icmp6CreateFile)
and assigned(Icmp6SendEcho2);
end;
end;
finalization
begin
FreeLibrary(IcmpDllHandle);
end;
{$ENDIF}
end.

483
synapse/pop3send.pas Normal file
View File

@ -0,0 +1,483 @@
{==============================================================================|
| Project : Ararat Synapse | 002.006.002 |
|==============================================================================|
| Content: POP3 client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(POP3 protocol client)
Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$M+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit pop3send;
interface
uses
SysUtils, Classes,
blcksock, synautil, synacode;
const
cPop3Protocol = '110';
type
{:The three types of possible authorization methods for "logging in" to a POP3
server.}
TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP);
{:@abstract(Implementation of POP3 client protocol.)
Note: Are you missing properties for setting Username and Password? Look to
parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TPOP3Send = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
FStatCount: Integer;
FStatSize: Integer;
FListSize: Integer;
FTimeStamp: string;
FAuthType: TPOP3AuthType;
FPOP3cap: TStringList;
FAutoTLS: Boolean;
FFullSSL: Boolean;
function ReadResult(Full: Boolean): Integer;
function Connect: Boolean;
function AuthLogin: Boolean;
function AuthApop: Boolean;
public
constructor Create;
destructor Destroy; override;
{:You can call any custom by this method. Call Command without trailing CRLF.
If MultiLine parameter is @true, multilined response are expected.
Result is @true on sucess.}
function CustomCommand(const Command: string; MultiLine: Boolean): boolean;
{:Call CAPA command for get POP3 server capabilites.
note: not all servers support this command!}
function Capability: Boolean;
{:Connect to remote POP3 host. If all OK, result is @true.}
function Login: Boolean;
{:Disconnects from POP3 server.}
function Logout: Boolean;
{:Send RSET command. If all OK, result is @true.}
function Reset: Boolean;
{:Send NOOP command. If all OK, result is @true.}
function NoOp: Boolean;
{:Send STAT command and fill @link(StatCount) and @link(StatSize) property.
If all OK, result is @true.}
function Stat: Boolean;
{:Send LIST command. If Value is 0, LIST is for all messages. After
successful operation is listing in FullResult. If all OK, result is @True.}
function List(Value: Integer): Boolean;
{:Send RETR command. After successful operation dowloaded message in
@link(FullResult). If all OK, result is @true.}
function Retr(Value: Integer): Boolean;
{:Send RETR command. After successful operation dowloaded message in
@link(Stream). If all OK, result is @true.}
function RetrStream(Value: Integer; Stream: TStream): Boolean;
{:Send DELE command for delete specified message. If all OK, result is @true.}
function Dele(Value: Integer): Boolean;
{:Send TOP command. After successful operation dowloaded headers of message
and maxlines count of message in @link(FullResult). If all OK, result is
@true.}
function Top(Value, Maxlines: Integer): Boolean;
{:Send UIDL command. If Value is 0, UIDL is for all messages. After
successful operation is listing in FullResult. If all OK, result is @True.}
function Uidl(Value: Integer): Boolean;
{:Call STLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:Try to find given capabily in capabilty string returned from POP3 server
by CAPA command.}
function FindCap(const Value: string): string;
published
{:Result code of last POP3 operation. 0 - error, 1 - OK.}
property ResultCode: Integer read FResultCode;
{:Result string of last POP3 operation.}
property ResultString: string read FResultString;
{:Stringlist with full lines returned as result of POP3 operation. I.e. if
operation is LIST, this property is filled by list of messages. If
operation is RETR, this property have downloaded message.}
property FullResult: TStringList read FFullResult;
{:After STAT command is there count of messages in inbox.}
property StatCount: Integer read FStatCount;
{:After STAT command is there size of all messages in inbox.}
property StatSize: Integer read FStatSize;
{:After LIST 0 command size of all messages on server, After LIST x size of message x on server}
property ListSize: Integer read FListSize;
{:If server support this, after comnnect is in this property timestamp of
remote server.}
property TimeStamp: string read FTimeStamp;
{:Type of authorisation for login to POP3 server. Dafault is autodetect one
of possible authorisation. Autodetect do this:
If remote POP3 server support APOP, try login by APOP method. If APOP is
not supported, or if APOP login failed, try classic USER+PASS login method.}
property AuthType: TPOP3AuthType read FAuthType Write FAuthType;
{:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
end;
implementation
constructor TPOP3Send.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FPOP3cap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := true;
FTimeout := 60000;
FTargetPort := cPop3Protocol;
FStatCount := 0;
FStatSize := 0;
FListSize := 0;
FAuthType := POP3AuthAll;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TPOP3Send.Destroy;
begin
FSock.Free;
FPOP3cap.Free;
FullResult.Free;
inherited Destroy;
end;
function TPOP3Send.ReadResult(Full: Boolean): Integer;
var
s: AnsiString;
begin
Result := 0;
FFullResult.Clear;
s := FSock.RecvString(FTimeout);
if Pos('+OK', s) = 1 then
Result := 1;
FResultString := s;
if Full and (Result = 1) then
repeat
s := FSock.RecvString(FTimeout);
if s = '.' then
Break;
if s <> '' then
if s[1] = '.' then
Delete(s, 1, 1);
FFullResult.Add(s);
until FSock.LastError <> 0;
if not Full and (Result = 1) then
FFullResult.Add(SeparateRight(FResultString, ' '));
if FSock.LastError <> 0 then
Result := 0;
FResultCode := Result;
end;
function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean;
begin
FSock.SendString(Command + CRLF);
Result := ReadResult(MultiLine) <> 0;
end;
function TPOP3Send.AuthLogin: Boolean;
begin
Result := False;
if not CustomCommand('USER ' + FUserName, False) then
exit;
Result := CustomCommand('PASS ' + FPassword, False)
end;
function TPOP3Send.AuthAPOP: Boolean;
var
s: string;
begin
s := StrToHex(MD5(FTimeStamp + FPassWord));
Result := CustomCommand('APOP ' + FUserName + ' ' + s, False);
end;
function TPOP3Send.Connect: Boolean;
begin
// Do not call this function! It is calling by LOGIN method!
FStatCount := 0;
FStatSize := 0;
FSock.CloseSocket;
FSock.LineBuffer := '';
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TPOP3Send.Capability: Boolean;
begin
FPOP3cap.Clear;
Result := CustomCommand('CAPA', True);
if Result then
FPOP3cap.AddStrings(FFullResult);
end;
function TPOP3Send.Login: Boolean;
var
s, s1: string;
begin
Result := False;
FTimeStamp := '';
if not Connect then
Exit;
if ReadResult(False) <> 1 then
Exit;
s := SeparateRight(FResultString, '<');
if s <> FResultString then
begin
s1 := Trim(SeparateLeft(s, '>'));
if s1 <> s then
FTimeStamp := '<' + s1 + '>';
end;
Result := False;
if Capability then
if FAutoTLS and (Findcap('STLS') <> '') then
if StartTLS then
Capability
else
begin
Result := False;
Exit;
end;
if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then
begin
Result := AuthApop;
if not Result then
begin
if not Connect then
Exit;
if ReadResult(False) <> 1 then
Exit;
end;
end;
if not Result and not (FAuthType = POP3AuthAPOP) then
Result := AuthLogin;
end;
function TPOP3Send.Logout: Boolean;
begin
Result := CustomCommand('QUIT', False);
FSock.CloseSocket;
end;
function TPOP3Send.Reset: Boolean;
begin
Result := CustomCommand('RSET', False);
end;
function TPOP3Send.NoOp: Boolean;
begin
Result := CustomCommand('NOOP', False);
end;
function TPOP3Send.Stat: Boolean;
var
s: string;
begin
Result := CustomCommand('STAT', False);
if Result then
begin
s := SeparateRight(ResultString, '+OK ');
FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0);
FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0);
end;
end;
function TPOP3Send.List(Value: Integer): Boolean;
var
s: string;
n: integer;
begin
if Value = 0 then
s := 'LIST'
else
s := 'LIST ' + IntToStr(Value);
Result := CustomCommand(s, Value = 0);
FListSize := 0;
if Result then
if Value <> 0 then
begin
s := SeparateRight(ResultString, '+OK ');
FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
end
else
for n := 0 to FFullResult.Count - 1 do
FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0);
end;
function TPOP3Send.Retr(Value: Integer): Boolean;
begin
Result := CustomCommand('RETR ' + IntToStr(Value), True);
end;
//based on code by Miha Vrhovnik
function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean;
var
s: string;
begin
Result := False;
FFullResult.Clear;
Stream.Size := 0;
FSock.SendString('RETR ' + IntToStr(Value) + CRLF);
s := FSock.RecvString(FTimeout);
if Pos('+OK', s) = 1 then
Result := True;
FResultString := s;
if Result then begin
repeat
s := FSock.RecvString(FTimeout);
if s = '.' then
Break;
if s <> '' then begin
if s[1] = '.' then
Delete(s, 1, 1);
end;
WriteStrToStream(Stream, s);
WriteStrToStream(Stream, CRLF);
until FSock.LastError <> 0;
end;
if Result then
FResultCode := 1
else
FResultCode := 0;
end;
function TPOP3Send.Dele(Value: Integer): Boolean;
begin
Result := CustomCommand('DELE ' + IntToStr(Value), False);
end;
function TPOP3Send.Top(Value, Maxlines: Integer): Boolean;
begin
Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True);
end;
function TPOP3Send.Uidl(Value: Integer): Boolean;
var
s: string;
begin
if Value = 0 then
s := 'UIDL'
else
s := 'UIDL ' + IntToStr(Value);
Result := CustomCommand(s, Value = 0);
end;
function TPOP3Send.StartTLS: Boolean;
begin
Result := False;
if CustomCommand('STLS', False) then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
function TPOP3Send.FindCap(const Value: string): string;
var
n: Integer;
s: string;
begin
s := UpperCase(Value);
Result := '';
for n := 0 to FPOP3cap.Count - 1 do
if Pos(s, UpperCase(FPOP3cap[n])) = 1 then
begin
Result := FPOP3cap[n];
Break;
end;
end;
end.

320
synapse/slogsend.pas Normal file
View File

@ -0,0 +1,320 @@
{==============================================================================|
| Project : Ararat Synapse | 001.002.003 |
|==============================================================================|
| Content: SysLog client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Christian Brosius |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(BSD SYSLOG protocol)
Used RFC: RFC-3164
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit slogsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cSysLogProtocol = '514';
FCL_Kernel = 0;
FCL_UserLevel = 1;
FCL_MailSystem = 2;
FCL_System = 3;
FCL_Security = 4;
FCL_Syslogd = 5;
FCL_Printer = 6;
FCL_News = 7;
FCL_UUCP = 8;
FCL_Clock = 9;
FCL_Authorization = 10;
FCL_FTP = 11;
FCL_NTP = 12;
FCL_LogAudit = 13;
FCL_LogAlert = 14;
FCL_Time = 15;
FCL_Local0 = 16;
FCL_Local1 = 17;
FCL_Local2 = 18;
FCL_Local3 = 19;
FCL_Local4 = 20;
FCL_Local5 = 21;
FCL_Local6 = 22;
FCL_Local7 = 23;
type
{:@abstract(Define possible priority of Syslog message)}
TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info,
Debug);
{:@abstract(encoding or decoding of SYSLOG message)}
TSyslogMessage = class(TObject)
private
FFacility:Byte;
FSeverity:TSyslogSeverity;
FDateTime:TDateTime;
FTag:String;
FMessage:String;
FLocalIP:String;
function GetPacketBuf:String;
procedure SetPacketBuf(Value:String);
public
{:Reset values to defaults}
procedure Clear;
published
{:Define facilicity of Syslog message. For specify you may use predefined
FCL_* constants. Default is "FCL_Local0".}
property Facility:Byte read FFacility write FFacility;
{:Define possible priority of Syslog message. Default is "Debug".}
property Severity:TSyslogSeverity read FSeverity write FSeverity;
{:date and time of Syslog message}
property DateTime:TDateTime read FDateTime write FDateTime;
{:This is used for identify process of this message. Default is filename
of your executable file.}
property Tag:String read FTag write FTag;
{:Text of your message for log.}
property LogMessage:String read FMessage write FMessage;
{:IP address of message sender.}
property LocalIP:String read FLocalIP write FLocalIP;
{:This property holds encoded binary SYSLOG packet}
property PacketBuf:String read GetPacketBuf write SetPacketBuf;
end;
{:@abstract(This object implement BSD SysLog client)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSyslogSend = class(TSynaClient)
private
FSock: TUDPBlockSocket;
FSysLogMessage: TSysLogMessage;
public
constructor Create;
destructor Destroy; override;
{:Send Syslog UDP packet defined by @link(SysLogMessage).}
function DoIt: Boolean;
published
{:Syslog message for send}
property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage;
end;
{:Simply send packet to specified Syslog server.}
function ToSysLog(const SyslogServer: string; Facil: Byte;
Sever: TSyslogSeverity; const Content: string): Boolean;
implementation
function TSyslogMessage.GetPacketBuf:String;
begin
Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>';
Result := Result + CDateTime(FDateTime) + ' ';
Result := Result + FLocalIP + ' ';
Result := Result + FTag + ': ' + FMessage;
end;
procedure TSyslogMessage.SetPacketBuf(Value:String);
var StrBuf:String;
IntBuf,Pos:Integer;
begin
if Length(Value) < 1 then exit;
Pos := 1;
if Value[Pos] <> '<' then exit;
Inc(Pos);
// Facility and Severity
StrBuf := '';
while (Value[Pos] <> '>')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
IntBuf := StrToInt(StrBuf);
FFacility := IntBuf div 8;
case (IntBuf mod 8)of
0:FSeverity := Emergency;
1:FSeverity := Alert;
2:FSeverity := Critical;
3:FSeverity := Error;
4:FSeverity := Warning;
5:FSeverity := Notice;
6:FSeverity := Info;
7:FSeverity := Debug;
end;
// DateTime
Inc(Pos);
StrBuf := '';
// Month
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
// Day
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
// Time
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FDateTime := DecodeRFCDateTime(StrBuf);
Inc(Pos);
// LocalIP
StrBuf := '';
while (Value[Pos] <> ' ')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FLocalIP := StrBuf;
Inc(Pos);
// Tag
StrBuf := '';
while (Value[Pos] <> ':')do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FTag := StrBuf;
// LogMessage
Inc(Pos);
StrBuf := '';
while (Pos <= Length(Value))do
begin
StrBuf := StrBuf + Value[Pos];
Inc(Pos);
end;
FMessage := TrimSP(StrBuf);
end;
procedure TSysLogMessage.Clear;
begin
FFacility := FCL_Local0;
FSeverity := Debug;
FTag := ExtractFileName(ParamStr(0));
FMessage := '';
FLocalIP := '0.0.0.0';
end;
//------------------------------------------------------------------------------
constructor TSyslogSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FSysLogMessage := TSysLogMessage.Create;
FTargetPort := cSysLogProtocol;
end;
destructor TSyslogSend.Destroy;
begin
FSock.Free;
FSysLogMessage.Free;
inherited Destroy;
end;
function TSyslogSend.DoIt: Boolean;
var
L: TStringList;
begin
Result := False;
L := TStringList.Create;
try
FSock.ResolveNameToIP(FSock.Localname, L);
if L.Count < 1 then
FSysLogMessage.LocalIP := '0.0.0.0'
else
FSysLogMessage.LocalIP := L[0];
finally
L.Free;
end;
FSysLogMessage.DateTime := Now;
if Length(FSysLogMessage.PacketBuf) <= 1024 then
begin
FSock.Connect(FTargetHost, FTargetPort);
FSock.SendString(FSysLogMessage.PacketBuf);
Result := FSock.LastError = 0;
end;
end;
{==============================================================================}
function ToSysLog(const SyslogServer: string; Facil: Byte;
Sever: TSyslogSeverity; const Content: string): Boolean;
begin
with TSyslogSend.Create do
try
TargetHost :=SyslogServer;
SysLogMessage.Facility := Facil;
SysLogMessage.Severity := Sever;
SysLogMessage.LogMessage := Content;
Result := DoIt;
finally
Free;
end;
end;
end.

724
synapse/smtpsend.pas Normal file
View File

@ -0,0 +1,724 @@
{==============================================================================|
| Project : Ararat Synapse | 003.005.001 |
|==============================================================================|
| Content: SMTP client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 1999-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SMTP client)
Used RFC: RFC-1869, RFC-1870, RFC-1893, RFC-2034, RFC-2104, RFC-2195, RFC-2487,
RFC-2554, RFC-2821
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit smtpsend;
interface
uses
SysUtils, Classes,
blcksock, synautil, synacode;
const
cSmtpProtocol = '25';
type
{:@abstract(Implementation of SMTP and ESMTP procotol),
include some ESMTP extensions, include SSL/TLS too.
Note: Are you missing properties for setting Username and Password for ESMTP?
Look to parent @link(TSynaClient) object!
Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSMTPSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FResultCode: Integer;
FResultString: string;
FFullResult: TStringList;
FESMTPcap: TStringList;
FESMTP: Boolean;
FAuthDone: Boolean;
FESMTPSize: Boolean;
FMaxSize: Integer;
FEnhCode1: Integer;
FEnhCode2: Integer;
FEnhCode3: Integer;
FSystemName: string;
FAutoTLS: Boolean;
FFullSSL: Boolean;
procedure EnhancedCode(const Value: string);
function ReadResult: Integer;
function AuthLogin: Boolean;
function AuthCram: Boolean;
function AuthPlain: Boolean;
function Helo: Boolean;
function Ehlo: Boolean;
function Connect: Boolean;
public
constructor Create;
destructor Destroy; override;
{:Connects to SMTP server (defined in @link(TSynaClient.TargetHost)) and
begin SMTP session. (First try ESMTP EHLO, next old HELO handshake). Parses
ESMTP capabilites and if you specified Username and password and remote
server can handle AUTH command, try login by AUTH command. Preffered login
method is CRAM-MD5 (if safer!). If all OK, result is @true, else result is
@false.}
function Login: Boolean;
{:Close SMTP session (QUIT command) and disconnect from SMTP server.}
function Logout: Boolean;
{:Send RSET SMTP command for reset SMTP session. If all OK, result is @true,
else result is @false.}
function Reset: Boolean;
{:Send NOOP SMTP command for keep SMTP session. If all OK, result is @true,
else result is @false.}
function NoOp: Boolean;
{:Send MAIL FROM SMTP command for set sender e-mail address. If sender's
e-mail address is empty string, transmited message is error message.
If size not 0 and remote server can handle SIZE parameter, append SIZE
parameter to request. If all OK, result is @true, else result is @false.}
function MailFrom(const Value: string; Size: Integer): Boolean;
{:Send RCPT TO SMTP command for set receiver e-mail address. It cannot be an
empty string. If all OK, result is @true, else result is @false.}
function MailTo(const Value: string): Boolean;
{:Send DATA SMTP command and transmit message data. If all OK, result is
@true, else result is @false.}
function MailData(const Value: Tstrings): Boolean;
{:Send ETRN SMTP command for start sending of remote queue for domain in
Value. If all OK, result is @true, else result is @false.}
function Etrn(const Value: string): Boolean;
{:Send VRFY SMTP command for check receiver e-mail address. It cannot be
an empty string. If all OK, result is @true, else result is @false.}
function Verify(const Value: string): Boolean;
{:Call STARTTLS command for upgrade connection to SSL/TLS mode.}
function StartTLS: Boolean;
{:Return string descriptive text for enhanced result codes stored in
@link(EnhCode1), @link(EnhCode2) and @link(EnhCode3).}
function EnhCodeString: string;
{:Try to find specified capability in ESMTP response.}
function FindCap(const Value: string): string;
published
{:result code of last SMTP command.}
property ResultCode: Integer read FResultCode;
{:result string of last SMTP command (begin with string representation of
result code).}
property ResultString: string read FResultString;
{:All result strings of last SMTP command (result is maybe multiline!).}
property FullResult: TStringList read FFullResult;
{:List of ESMTP capabilites of remote ESMTP server. (If you connect to ESMTP
server only!).}
property ESMTPcap: TStringList read FESMTPcap;
{:@TRUE if you successfuly logged to ESMTP server.}
property ESMTP: Boolean read FESMTP;
{:@TRUE if you successfuly pass authorisation to remote server.}
property AuthDone: Boolean read FAuthDone;
{:@TRUE if remote server can handle SIZE parameter.}
property ESMTPSize: Boolean read FESMTPSize;
{:When @link(ESMTPsize) is @TRUE, contains max length of message that remote
server can handle.}
property MaxSize: Integer read FMaxSize;
{:First digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode1: Integer read FEnhCode1;
{:Second digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode2: Integer read FEnhCode2;
{:Third digit of Enhanced result code. If last operation does not have
enhanced result code, values is 0.}
property EnhCode3: Integer read FEnhCode3;
{:name of our system used in HELO and EHLO command. Implicit value is
internet address of your machine.}
property SystemName: string read FSystemName Write FSystemName;
{:If is set to true, then upgrade to SSL/TLS mode if remote server support it.}
property AutoTLS: Boolean read FAutoTLS Write FAutoTLS;
{:SSL/TLS mode is used from first contact to server. Servers with full
SSL/TLS mode usualy using non-standard TCP port!}
property FullSSL: Boolean read FFullSSL Write FFullSSL;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
end;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Send maildata (text of e-mail with all SMTP headers! For example when
text of message is created by @link(TMimemess) object) from "MailFrom" e-mail
address to "MailTo" e-mail address (If you need more then one receiver, then
separate their addresses by comma).
Function sends e-mail to a SMTP server defined in "SMTPhost" parameter.
Username and password are used for authorization to the "SMTPhost". If you
don't want authorization, set "Username" and "Password" to empty strings. If
e-mail message is successfully sent, the result returns @true.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Send "Maildata" (text of e-mail without any SMTP headers!) from
"MailFrom" e-mail address to "MailTo" e-mail address with "Subject". (If you
need more then one receiver, then separate their addresses by comma).
This function constructs all needed SMTP headers (with DATE header) and sends
the e-mail to the SMTP server defined in the "SMTPhost" parameter. If the
e-mail message is successfully sent, the result will be @TRUE.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings): Boolean;
{:A very useful function and example of its use would be found in the TSMTPsend
object. Sends "MailData" (text of e-mail without any SMTP headers!) from
"MailFrom" e-mail address to "MailTo" e-mail address (If you need more then one
receiver, then separate their addresses by comma).
This function sends the e-mail to the SMTP server defined in the "SMTPhost"
parameter. Username and password are used for authorization to the "SMTPhost".
If you dont want authorization, set "Username" and "Password" to empty Strings.
If the e-mail message is successfully sent, the result will be @TRUE.
If you need use different port number then standard, then add this port number
to SMTPhost after colon. (i.e. '127.0.0.1:1025')}
function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
implementation
constructor TSMTPSend.Create;
begin
inherited Create;
FFullResult := TStringList.Create;
FESMTPcap := TStringList.Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.ConvertLineEnd := true;
FTimeout := 60000;
FTargetPort := cSmtpProtocol;
FSystemName := FSock.LocalName;
FAutoTLS := False;
FFullSSL := False;
end;
destructor TSMTPSend.Destroy;
begin
FSock.Free;
FESMTPcap.Free;
FFullResult.Free;
inherited Destroy;
end;
procedure TSMTPSend.EnhancedCode(const Value: string);
var
s, t: string;
e1, e2, e3: Integer;
begin
FEnhCode1 := 0;
FEnhCode2 := 0;
FEnhCode3 := 0;
s := Copy(Value, 5, Length(Value) - 4);
t := Trim(SeparateLeft(s, '.'));
s := Trim(SeparateRight(s, '.'));
if t = '' then
Exit;
if Length(t) > 1 then
Exit;
e1 := StrToIntDef(t, 0);
if e1 = 0 then
Exit;
t := Trim(SeparateLeft(s, '.'));
s := Trim(SeparateRight(s, '.'));
if t = '' then
Exit;
if Length(t) > 3 then
Exit;
e2 := StrToIntDef(t, 0);
t := Trim(SeparateLeft(s, ' '));
if t = '' then
Exit;
if Length(t) > 3 then
Exit;
e3 := StrToIntDef(t, 0);
FEnhCode1 := e1;
FEnhCode2 := e2;
FEnhCode3 := e3;
end;
function TSMTPSend.ReadResult: Integer;
var
s: String;
begin
Result := 0;
FFullResult.Clear;
repeat
s := FSock.RecvString(FTimeout);
FResultString := s;
FFullResult.Add(s);
if FSock.LastError <> 0 then
Break;
until Pos('-', s) <> 4;
s := FFullResult[0];
if Length(s) >= 3 then
Result := StrToIntDef(Copy(s, 1, 3), 0);
FResultCode := Result;
EnhancedCode(s);
end;
function TSMTPSend.AuthLogin: Boolean;
begin
Result := False;
FSock.SendString('AUTH LOGIN' + CRLF);
if ReadResult <> 334 then
Exit;
FSock.SendString(EncodeBase64(FUsername) + CRLF);
if ReadResult <> 334 then
Exit;
FSock.SendString(EncodeBase64(FPassword) + CRLF);
Result := ReadResult = 235;
end;
function TSMTPSend.AuthCram: Boolean;
var
s: ansistring;
begin
Result := False;
FSock.SendString('AUTH CRAM-MD5' + CRLF);
if ReadResult <> 334 then
Exit;
s := Copy(FResultString, 5, Length(FResultString) - 4);
s := DecodeBase64(s);
s := HMAC_MD5(s, FPassword);
s := FUsername + ' ' + StrToHex(s);
FSock.SendString(EncodeBase64(s) + CRLF);
Result := ReadResult = 235;
end;
function TSMTPSend.AuthPlain: Boolean;
var
s: ansistring;
begin
s := ansichar(0) + FUsername + ansichar(0) + FPassword;
FSock.SendString('AUTH PLAIN ' + EncodeBase64(s) + CRLF);
Result := ReadResult = 235;
end;
function TSMTPSend.Connect: Boolean;
begin
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
if FSock.LastError = 0 then
FSock.Connect(FTargetHost, FTargetPort);
if FSock.LastError = 0 then
if FFullSSL then
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
function TSMTPSend.Helo: Boolean;
var
x: Integer;
begin
FSock.SendString('HELO ' + FSystemName + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.Ehlo: Boolean;
var
x: Integer;
begin
FSock.SendString('EHLO ' + FSystemName + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.Login: Boolean;
var
n: Integer;
auths: string;
s: string;
begin
Result := False;
FESMTP := True;
FAuthDone := False;
FESMTPcap.clear;
FESMTPSize := False;
FMaxSize := 0;
if not Connect then
Exit;
if ReadResult <> 220 then
Exit;
if not Ehlo then
begin
FESMTP := False;
if not Helo then
Exit;
end;
Result := True;
if FESMTP then
begin
for n := 1 to FFullResult.Count - 1 do
FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then
if StartTLS then
begin
Ehlo;
FESMTPcap.Clear;
for n := 1 to FFullResult.Count - 1 do
FESMTPcap.Add(Copy(FFullResult[n], 5, Length(FFullResult[n]) - 4));
end
else
begin
Result := False;
Exit;
end;
if not ((FUsername = '') and (FPassword = '')) then
begin
s := FindCap('AUTH ');
if s = '' then
s := FindCap('AUTH=');
auths := UpperCase(s);
if s <> '' then
begin
if Pos('CRAM-MD5', auths) > 0 then
FAuthDone := AuthCram;
if (not FauthDone) and (Pos('PLAIN', auths) > 0) then
FAuthDone := AuthPlain;
if (not FauthDone) and (Pos('LOGIN', auths) > 0) then
FAuthDone := AuthLogin;
end;
end;
s := FindCap('SIZE');
if s <> '' then
begin
FESMTPsize := True;
FMaxSize := StrToIntDef(Copy(s, 6, Length(s) - 5), 0);
end;
end;
end;
function TSMTPSend.Logout: Boolean;
begin
FSock.SendString('QUIT' + CRLF);
Result := ReadResult = 221;
FSock.CloseSocket;
end;
function TSMTPSend.Reset: Boolean;
begin
FSock.SendString('RSET' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.NoOp: Boolean;
begin
FSock.SendString('NOOP' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.MailFrom(const Value: string; Size: Integer): Boolean;
var
s: string;
begin
s := 'MAIL FROM:<' + Value + '>';
if FESMTPsize and (Size > 0) then
s := s + ' SIZE=' + IntToStr(Size);
FSock.SendString(s + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.MailTo(const Value: string): Boolean;
begin
FSock.SendString('RCPT TO:<' + Value + '>' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.MailData(const Value: TStrings): Boolean;
var
n: Integer;
s: string;
t: string;
x: integer;
begin
Result := False;
FSock.SendString('DATA' + CRLF);
if ReadResult <> 354 then
Exit;
t := '';
x := 1500;
for n := 0 to Value.Count - 1 do
begin
s := Value[n];
if Length(s) >= 1 then
if s[1] = '.' then
s := '.' + s;
if Length(t) + Length(s) >= x then
begin
FSock.SendString(t);
t := '';
end;
t := t + s + CRLF;
end;
if t <> '' then
FSock.SendString(t);
FSock.SendString('.' + CRLF);
Result := ReadResult div 100 = 2;
end;
function TSMTPSend.Etrn(const Value: string): Boolean;
var
x: Integer;
begin
FSock.SendString('ETRN ' + Value + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.Verify(const Value: string): Boolean;
var
x: Integer;
begin
FSock.SendString('VRFY ' + Value + CRLF);
x := ReadResult;
Result := (x >= 250) and (x <= 259);
end;
function TSMTPSend.StartTLS: Boolean;
begin
Result := False;
if FindCap('STARTTLS') <> '' then
begin
FSock.SendString('STARTTLS' + CRLF);
if (ReadResult = 220) and (FSock.LastError = 0) then
begin
Fsock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
end;
function TSMTPSend.EnhCodeString: string;
var
s, t: string;
begin
s := IntToStr(FEnhCode2) + '.' + IntToStr(FEnhCode3);
t := '';
if s = '0.0' then t := 'Other undefined Status';
if s = '1.0' then t := 'Other address status';
if s = '1.1' then t := 'Bad destination mailbox address';
if s = '1.2' then t := 'Bad destination system address';
if s = '1.3' then t := 'Bad destination mailbox address syntax';
if s = '1.4' then t := 'Destination mailbox address ambiguous';
if s = '1.5' then t := 'Destination mailbox address valid';
if s = '1.6' then t := 'Mailbox has moved';
if s = '1.7' then t := 'Bad sender''s mailbox address syntax';
if s = '1.8' then t := 'Bad sender''s system address';
if s = '2.0' then t := 'Other or undefined mailbox status';
if s = '2.1' then t := 'Mailbox disabled, not accepting messages';
if s = '2.2' then t := 'Mailbox full';
if s = '2.3' then t := 'Message Length exceeds administrative limit';
if s = '2.4' then t := 'Mailing list expansion problem';
if s = '3.0' then t := 'Other or undefined mail system status';
if s = '3.1' then t := 'Mail system full';
if s = '3.2' then t := 'System not accepting network messages';
if s = '3.3' then t := 'System not capable of selected features';
if s = '3.4' then t := 'Message too big for system';
if s = '3.5' then t := 'System incorrectly configured';
if s = '4.0' then t := 'Other or undefined network or routing status';
if s = '4.1' then t := 'No answer from host';
if s = '4.2' then t := 'Bad connection';
if s = '4.3' then t := 'Routing server failure';
if s = '4.4' then t := 'Unable to route';
if s = '4.5' then t := 'Network congestion';
if s = '4.6' then t := 'Routing loop detected';
if s = '4.7' then t := 'Delivery time expired';
if s = '5.0' then t := 'Other or undefined protocol status';
if s = '5.1' then t := 'Invalid command';
if s = '5.2' then t := 'Syntax error';
if s = '5.3' then t := 'Too many recipients';
if s = '5.4' then t := 'Invalid command arguments';
if s = '5.5' then t := 'Wrong protocol version';
if s = '6.0' then t := 'Other or undefined media error';
if s = '6.1' then t := 'Media not supported';
if s = '6.2' then t := 'Conversion required and prohibited';
if s = '6.3' then t := 'Conversion required but not supported';
if s = '6.4' then t := 'Conversion with loss performed';
if s = '6.5' then t := 'Conversion failed';
if s = '7.0' then t := 'Other or undefined security status';
if s = '7.1' then t := 'Delivery not authorized, message refused';
if s = '7.2' then t := 'Mailing list expansion prohibited';
if s = '7.3' then t := 'Security conversion required but not possible';
if s = '7.4' then t := 'Security features not supported';
if s = '7.5' then t := 'Cryptographic failure';
if s = '7.6' then t := 'Cryptographic algorithm not supported';
if s = '7.7' then t := 'Message integrity failure';
s := '???-';
if FEnhCode1 = 2 then s := 'Success-';
if FEnhCode1 = 4 then s := 'Persistent Transient Failure-';
if FEnhCode1 = 5 then s := 'Permanent Failure-';
Result := s + t;
end;
function TSMTPSend.FindCap(const Value: string): string;
var
n: Integer;
s: string;
begin
s := UpperCase(Value);
Result := '';
for n := 0 to FESMTPcap.Count - 1 do
if Pos(s, UpperCase(FESMTPcap[n])) = 1 then
begin
Result := FESMTPcap[n];
Break;
end;
end;
{==============================================================================}
function SendToRaw(const MailFrom, MailTo, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
var
SMTP: TSMTPSend;
s, t: string;
begin
Result := False;
SMTP := TSMTPSend.Create;
try
// if you need SOCKS5 support, uncomment next lines:
// SMTP.Sock.SocksIP := '127.0.0.1';
// SMTP.Sock.SocksPort := '1080';
// if you need support for upgrade session to TSL/SSL, uncomment next lines:
// SMTP.AutoTLS := True;
// if you need support for TSL/SSL tunnel, uncomment next lines:
// SMTP.FullSSL := True;
SMTP.TargetHost := Trim(SeparateLeft(SMTPHost, ':'));
s := Trim(SeparateRight(SMTPHost, ':'));
if (s <> '') and (s <> SMTPHost) then
SMTP.TargetPort := s;
SMTP.Username := Username;
SMTP.Password := Password;
if SMTP.Login then
begin
if SMTP.MailFrom(GetEmailAddr(MailFrom), Length(MailData.Text)) then
begin
s := MailTo;
repeat
t := GetEmailAddr(Trim(FetchEx(s, ',', '"')));
if t <> '' then
Result := SMTP.MailTo(t);
if not Result then
Break;
until s = '';
if Result then
Result := SMTP.MailData(MailData);
end;
SMTP.Logout;
end;
finally
SMTP.Free;
end;
end;
function SendToEx(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings; const Username, Password: string): Boolean;
var
t: TStrings;
begin
t := TStringList.Create;
try
t.Assign(MailData);
t.Insert(0, '');
t.Insert(0, 'X-mailer: Synapse - Delphi & Kylix TCP/IP library by Lukas Gebauer');
t.Insert(0, 'Subject: ' + Subject);
t.Insert(0, 'Date: ' + Rfc822DateTime(now));
t.Insert(0, 'To: ' + MailTo);
t.Insert(0, 'From: ' + MailFrom);
Result := SendToRaw(MailFrom, MailTo, SMTPHost, t, Username, Password);
finally
t.Free;
end;
end;
function SendTo(const MailFrom, MailTo, Subject, SMTPHost: string;
const MailData: TStrings): Boolean;
begin
Result := SendToEx(MailFrom, MailTo, Subject, SMTPHost, MailData, '', '');
end;
end.

1266
synapse/snmpsend.pas Normal file
View File

File diff suppressed because it is too large Load Diff

374
synapse/sntpsend.pas Normal file
View File

@ -0,0 +1,374 @@
{==============================================================================|
| Project : Ararat Synapse | 003.000.003 |
|==============================================================================|
| Content: SNTP client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Patrick Chevalley |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract( NTP and SNTP client)
Used RFC: RFC-1305, RFC-2030
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit sntpsend;
interface
uses
SysUtils,
synsock, blcksock, synautil;
const
cNtpProtocol = '123';
type
{:@abstract(Record containing the NTP packet.)}
TNtp = packed record
mode: Byte;
stratum: Byte;
poll: Byte;
Precision: Byte;
RootDelay: Longint;
RootDisperson: Longint;
RefID: Longint;
Ref1: Longint;
Ref2: Longint;
Org1: Longint;
Org2: Longint;
Rcv1: Longint;
Rcv2: Longint;
Xmit1: Longint;
Xmit2: Longint;
end;
{:@abstract(Implementation of NTP and SNTP client protocol),
include time synchronisation. It can send NTP or SNTP time queries, or it
can receive NTP broadcasts too.
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSNTPSend = class(TSynaClient)
private
FNTPReply: TNtp;
FNTPTime: TDateTime;
FNTPOffset: double;
FNTPDelay: double;
FMaxSyncDiff: double;
FSyncTime: Boolean;
FSock: TUDPBlockSocket;
FBuffer: AnsiString;
FLi, FVn, Fmode : byte;
function StrToNTP(const Value: AnsiString): TNtp;
function NTPtoStr(const Value: Tntp): AnsiString;
procedure ClearNTP(var Value: Tntp);
public
constructor Create;
destructor Destroy; override;
{:Decode 128 bit timestamp used in NTP packet to TDateTime type.}
function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
{:Decode TDateTime type to 128 bit timestamp used in NTP packet.}
procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
valid.}
function GetSNTP: Boolean;
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
valid. Result time is after all needed corrections.}
function GetNTP: Boolean;
{:Wait for broadcast NTP packet. If all OK, result is @true and
@link(NTPReply) and @link(NTPTime) are valid.}
function GetBroadcastNTP: Boolean;
{:Holds last received NTP packet.}
property NTPReply: TNtp read FNTPReply;
published
{:Date and time of remote NTP or SNTP server. (UTC time!!!)}
property NTPTime: TDateTime read FNTPTime;
{:Offset between your computer and remote NTP or SNTP server.}
property NTPOffset: Double read FNTPOffset;
{:Delay between your computer and remote NTP or SNTP server.}
property NTPDelay: Double read FNTPDelay;
{:Define allowed maximum difference between your time and remote time for
synchronising time. If difference is bigger, your system time is not
changed!}
property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
{:If @true, after successfull getting time is local computer clock
synchronised to given time.
For synchronising time you must have proper rights! (Usually Administrator)}
property SyncTime: Boolean read FSyncTime write FSyncTime;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TUDPBlockSocket read FSock;
end;
implementation
constructor TSNTPSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 5000;
FTargetPort := cNtpProtocol;
FMaxSyncDiff := 3600;
FSyncTime := False;
end;
destructor TSNTPSend.Destroy;
begin
FSock.Free;
inherited Destroy;
end;
function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp;
begin
if length(FBuffer) >= SizeOf(Result) then
begin
Result.mode := ord(Value[1]);
Result.stratum := ord(Value[2]);
Result.poll := ord(Value[3]);
Result.Precision := ord(Value[4]);
Result.RootDelay := DecodeLongInt(value, 5);
Result.RootDisperson := DecodeLongInt(value, 9);
Result.RefID := DecodeLongInt(value, 13);
Result.Ref1 := DecodeLongInt(value, 17);
Result.Ref2 := DecodeLongInt(value, 21);
Result.Org1 := DecodeLongInt(value, 25);
Result.Org2 := DecodeLongInt(value, 29);
Result.Rcv1 := DecodeLongInt(value, 33);
Result.Rcv2 := DecodeLongInt(value, 37);
Result.Xmit1 := DecodeLongInt(value, 41);
Result.Xmit2 := DecodeLongInt(value, 45);
end;
end;
function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString;
begin
SetLength(Result, 4);
Result[1] := AnsiChar(Value.mode);
Result[2] := AnsiChar(Value.stratum);
Result[3] := AnsiChar(Value.poll);
Result[4] := AnsiChar(Value.precision);
Result := Result + CodeLongInt(Value.RootDelay);
Result := Result + CodeLongInt(Value.RootDisperson);
Result := Result + CodeLongInt(Value.RefID);
Result := Result + CodeLongInt(Value.Ref1);
Result := Result + CodeLongInt(Value.Ref2);
Result := Result + CodeLongInt(Value.Org1);
Result := Result + CodeLongInt(Value.Org2);
Result := Result + CodeLongInt(Value.Rcv1);
Result := Result + CodeLongInt(Value.Rcv2);
Result := Result + CodeLongInt(Value.Xmit1);
Result := Result + CodeLongInt(Value.Xmit2);
end;
procedure TSNTPSend.ClearNTP(var Value: Tntp);
begin
Value.mode := 0;
Value.stratum := 0;
Value.poll := 0;
Value.Precision := 0;
Value.RootDelay := 0;
Value.RootDisperson := 0;
Value.RefID := 0;
Value.Ref1 := 0;
Value.Ref2 := 0;
Value.Org1 := 0;
Value.Org2 := 0;
Value.Rcv1 := 0;
Value.Rcv2 := 0;
Value.Xmit1 := 0;
Value.Xmit2 := 0;
end;
function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
const
maxi = 4294967295.0;
var
d, d1: Double;
begin
d := Nsec;
if d < 0 then
d := maxi + d + 1;
d1 := Nfrac;
if d1 < 0 then
d1 := maxi + d1 + 1;
d1 := d1 / maxi;
d1 := Trunc(d1 * 10000) / 10000;
Result := (d + d1) / 86400;
Result := Result + 2;
end;
procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
const
maxi = 4294967295.0;
maxilongint = 2147483647;
var
d, d1: Double;
begin
d := (dt - 2) * 86400;
d1 := frac(d);
if d > maxilongint then
d := d - maxi - 1;
d := trunc(d);
d1 := Trunc(d1 * 10000) / 10000;
d1 := d1 * maxi;
if d1 > maxilongint then
d1 := d1 - maxi - 1;
Nsec:=trunc(d);
Nfrac:=trunc(d1);
end;
function TSNTPSend.GetBroadcastNTP: Boolean;
var
x: Integer;
begin
Result := False;
FSock.Bind(FIPInterface, FTargetPort);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
if x >= SizeOf(NTPReply) then
begin
FNTPReply := StrToNTP(FBuffer);
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime);
Result := True;
end;
end;
end;
function TSNTPSend.GetSNTP: Boolean;
var
q: TNtp;
x: Integer;
begin
Result := False;
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
ClearNtp(q);
q.mode := $1B;
FBuffer := NTPtoStr(q);
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
if x >= SizeOf(NTPReply) then
begin
FNTPReply := StrToNTP(FBuffer);
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime);
Result := True;
end;
end;
end;
function TSNTPSend.GetNTP: Boolean;
var
q: TNtp;
x: Integer;
t1, t2, t3, t4 : TDateTime;
begin
Result := False;
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
ClearNtp(q);
q.mode := $1B;
t1 := GetUTTime;
EncodeTs(t1, q.org1, q.org2);
FBuffer := NTPtoStr(q);
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
t4 := GetUTTime;
if x >= SizeOf(NTPReply) then
begin
FNTPReply := StrToNTP(FBuffer);
FLi := (NTPReply.mode and $C0) shr 6;
FVn := (NTPReply.mode and $38) shr 3;
Fmode := NTPReply.mode and $07;
if (Fli < 3) and (Fmode = 4) and
(NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and
(NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0)
then begin
t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2);
t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
FNTPDelay := (T4 - T1) - (T2 - T3);
FNTPTime := t3 + FNTPDelay / 2;
FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400;
FNTPDelay := FNTPDelay * 86400;
if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime);
Result := True;
end
else result:=false;
end;
end;
end;
end.

1099
synapse/ssdotnet.inc Normal file
View File

File diff suppressed because it is too large Load Diff

909
synapse/ssfpc.inc Normal file
View File

@ -0,0 +1,909 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.004 |
|==============================================================================|
| Content: Socket Independent Platform Layer - FreePascal definition include |
|==============================================================================|
| Copyright (c)2006-2011, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2006-2011. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
{$IFDEF FPC}
{For FreePascal 2.x.x}
//{$DEFINE FORCEOLDAPI}
{Note about define FORCEOLDAPI:
If you activate this compiler directive, then is allways used old socket API
for name resolution. If you leave this directive inactive, then the new API
is used, when running system allows it.
For IPv6 support you must have new API!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$ifdef FreeBSD}
{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr
{$endif}
{$ifdef darwin}
{$DEFINE SOCK_HAS_SINLEN} // BSD definition of scoketaddr
{$endif}
interface
uses
SyncObjs, SysUtils, Classes,
synafpc, BaseUnix, Unix, termio, sockets, netdb;
function InitSocketInterface(stack: string): Boolean;
function DestroySocketInterface: Boolean;
const
DLLStackName = '';
WinsockLevel = $0202;
cLocalHost = '127.0.0.1';
cAnyHost = '0.0.0.0';
c6AnyHost = '::0';
c6Localhost = '::1';
cLocalHostStr = 'localhost';
type
TSocket = longint;
TAddrFamily = integer;
TMemory = pointer;
type
TFDSet = Baseunix.TFDSet;
PFDSet = ^TFDSet;
Ptimeval = Baseunix.ptimeval;
Ttimeval = Baseunix.ttimeval;
const
FIONREAD = termio.FIONREAD;
FIONBIO = termio.FIONBIO;
FIOASYNC = termio.FIOASYNC;
const
IPPROTO_IP = 0; { Dummy }
IPPROTO_ICMP = 1; { Internet Control Message Protocol }
IPPROTO_IGMP = 2; { Internet Group Management Protocol}
IPPROTO_TCP = 6; { TCP }
IPPROTO_UDP = 17; { User Datagram Protocol }
IPPROTO_IPV6 = 41;
IPPROTO_ICMPV6 = 58;
IPPROTO_RM = 113;
IPPROTO_RAW = 255;
IPPROTO_MAX = 256;
type
PInAddr = ^TInAddr;
TInAddr = sockets.in_addr;
PSockAddrIn = ^TSockAddrIn;
TSockAddrIn = sockets.TInetSockAddr;
TIP_mreq = record
imr_multiaddr: TInAddr; // IP multicast address of group
imr_interface: TInAddr; // local IP address of interface
end;
PInAddr6 = ^TInAddr6;
TInAddr6 = sockets.Tin6_addr;
PSockAddrIn6 = ^TSockAddrIn6;
TSockAddrIn6 = sockets.TInetSockAddr6;
TIPv6_mreq = record
ipv6mr_multiaddr: TInAddr6; // IPv6 multicast address.
ipv6mr_interface: integer; // Interface index.
end;
const
INADDR_ANY = $00000000;
INADDR_LOOPBACK = $7F000001;
INADDR_BROADCAST = $FFFFFFFF;
INADDR_NONE = $FFFFFFFF;
ADDR_ANY = INADDR_ANY;
INVALID_SOCKET = TSocket(NOT(0));
SOCKET_ERROR = -1;
Const
IP_TOS = sockets.IP_TOS; { int; IP type of service and precedence. }
IP_TTL = sockets.IP_TTL; { int; IP time to live. }
IP_HDRINCL = sockets.IP_HDRINCL; { int; Header is included with data. }
IP_OPTIONS = sockets.IP_OPTIONS; { ip_opts; IP per-packet options. }
// IP_ROUTER_ALERT = sockets.IP_ROUTER_ALERT; { bool }
IP_RECVOPTS = sockets.IP_RECVOPTS; { bool }
IP_RETOPTS = sockets.IP_RETOPTS; { bool }
// IP_PKTINFO = sockets.IP_PKTINFO; { bool }
// IP_PKTOPTIONS = sockets.IP_PKTOPTIONS;
// IP_PMTUDISC = sockets.IP_PMTUDISC; { obsolete name? }
// IP_MTU_DISCOVER = sockets.IP_MTU_DISCOVER; { int; see below }
// IP_RECVERR = sockets.IP_RECVERR; { bool }
// IP_RECVTTL = sockets.IP_RECVTTL; { bool }
// IP_RECVTOS = sockets.IP_RECVTOS; { bool }
IP_MULTICAST_IF = sockets.IP_MULTICAST_IF; { in_addr; set/get IP multicast i/f }
IP_MULTICAST_TTL = sockets.IP_MULTICAST_TTL; { u_char; set/get IP multicast ttl }
IP_MULTICAST_LOOP = sockets.IP_MULTICAST_LOOP; { i_char; set/get IP multicast loopback }
IP_ADD_MEMBERSHIP = sockets.IP_ADD_MEMBERSHIP; { ip_mreq; add an IP group membership }
IP_DROP_MEMBERSHIP = sockets.IP_DROP_MEMBERSHIP; { ip_mreq; drop an IP group membership }
SOL_SOCKET = sockets.SOL_SOCKET;
SO_DEBUG = sockets.SO_DEBUG;
SO_REUSEADDR = sockets.SO_REUSEADDR;
SO_TYPE = sockets.SO_TYPE;
SO_ERROR = sockets.SO_ERROR;
SO_DONTROUTE = sockets.SO_DONTROUTE;
SO_BROADCAST = sockets.SO_BROADCAST;
SO_SNDBUF = sockets.SO_SNDBUF;
SO_RCVBUF = sockets.SO_RCVBUF;
SO_KEEPALIVE = sockets.SO_KEEPALIVE;
SO_OOBINLINE = sockets.SO_OOBINLINE;
// SO_NO_CHECK = sockets.SO_NO_CHECK;
// SO_PRIORITY = sockets.SO_PRIORITY;
SO_LINGER = sockets.SO_LINGER;
// SO_BSDCOMPAT = sockets.SO_BSDCOMPAT;
// SO_REUSEPORT = sockets.SO_REUSEPORT;
// SO_PASSCRED = sockets.SO_PASSCRED;
// SO_PEERCRED = sockets.SO_PEERCRED;
SO_RCVLOWAT = sockets.SO_RCVLOWAT;
SO_SNDLOWAT = sockets.SO_SNDLOWAT;
SO_RCVTIMEO = sockets.SO_RCVTIMEO;
SO_SNDTIMEO = sockets.SO_SNDTIMEO;
{ Security levels - as per NRL IPv6 - don't actually do anything }
// SO_SECURITY_AUTHENTICATION = sockets.SO_SECURITY_AUTHENTICATION;
// SO_SECURITY_ENCRYPTION_TRANSPORT = sockets.SO_SECURITY_ENCRYPTION_TRANSPORT;
// SO_SECURITY_ENCRYPTION_NETWORK = sockets.SO_SECURITY_ENCRYPTION_NETWORK;
// SO_BINDTODEVICE = sockets.SO_BINDTODEVICE;
{ Socket filtering }
// SO_ATTACH_FILTER = sockets.SO_ATTACH_FILTER;
// SO_DETACH_FILTER = sockets.SO_DETACH_FILTER;
SOMAXCONN = 1024;
IPV6_UNICAST_HOPS = sockets.IPV6_UNICAST_HOPS;
IPV6_MULTICAST_IF = sockets.IPV6_MULTICAST_IF;
IPV6_MULTICAST_HOPS = sockets.IPV6_MULTICAST_HOPS;
IPV6_MULTICAST_LOOP = sockets.IPV6_MULTICAST_LOOP;
IPV6_JOIN_GROUP = sockets.IPV6_JOIN_GROUP;
IPV6_LEAVE_GROUP = sockets.IPV6_LEAVE_GROUP;
const
SOCK_STREAM = 1; { stream socket }
SOCK_DGRAM = 2; { datagram socket }
SOCK_RAW = 3; { raw-protocol interface }
SOCK_RDM = 4; { reliably-delivered message }
SOCK_SEQPACKET = 5; { sequenced packet stream }
{ TCP options. }
TCP_NODELAY = $0001;
{ Address families. }
AF_UNSPEC = 0; { unspecified }
AF_INET = 2; { internetwork: UDP, TCP, etc. }
AF_INET6 = 10; { Internetwork Version 6 }
AF_MAX = 24;
{ Protocol families, same as address families for now. }
PF_UNSPEC = AF_UNSPEC;
PF_INET = AF_INET;
PF_INET6 = AF_INET6;
PF_MAX = AF_MAX;
type
{ Structure used for manipulating linger option. }
PLinger = ^TLinger;
TLinger = packed record
l_onoff: integer;
l_linger: integer;
end;
const
MSG_OOB = sockets.MSG_OOB; // Process out-of-band data.
MSG_PEEK = sockets.MSG_PEEK; // Peek at incoming messages.
{$ifdef DARWIN}
MSG_NOSIGNAL = $20000; // Do not generate SIGPIPE.
// Works under MAC OS X, but is undocumented,
// So FPC doesn't include it
{$else}
MSG_NOSIGNAL = sockets.MSG_NOSIGNAL; // Do not generate SIGPIPE.
{$endif}
const
WSAEINTR = ESysEINTR;
WSAEBADF = ESysEBADF;
WSAEACCES = ESysEACCES;
WSAEFAULT = ESysEFAULT;
WSAEINVAL = ESysEINVAL;
WSAEMFILE = ESysEMFILE;
WSAEWOULDBLOCK = ESysEWOULDBLOCK;
WSAEINPROGRESS = ESysEINPROGRESS;
WSAEALREADY = ESysEALREADY;
WSAENOTSOCK = ESysENOTSOCK;
WSAEDESTADDRREQ = ESysEDESTADDRREQ;
WSAEMSGSIZE = ESysEMSGSIZE;
WSAEPROTOTYPE = ESysEPROTOTYPE;
WSAENOPROTOOPT = ESysENOPROTOOPT;
WSAEPROTONOSUPPORT = ESysEPROTONOSUPPORT;
WSAESOCKTNOSUPPORT = ESysESOCKTNOSUPPORT;
WSAEOPNOTSUPP = ESysEOPNOTSUPP;
WSAEPFNOSUPPORT = ESysEPFNOSUPPORT;
WSAEAFNOSUPPORT = ESysEAFNOSUPPORT;
WSAEADDRINUSE = ESysEADDRINUSE;
WSAEADDRNOTAVAIL = ESysEADDRNOTAVAIL;
WSAENETDOWN = ESysENETDOWN;
WSAENETUNREACH = ESysENETUNREACH;
WSAENETRESET = ESysENETRESET;
WSAECONNABORTED = ESysECONNABORTED;
WSAECONNRESET = ESysECONNRESET;
WSAENOBUFS = ESysENOBUFS;
WSAEISCONN = ESysEISCONN;
WSAENOTCONN = ESysENOTCONN;
WSAESHUTDOWN = ESysESHUTDOWN;
WSAETOOMANYREFS = ESysETOOMANYREFS;
WSAETIMEDOUT = ESysETIMEDOUT;
WSAECONNREFUSED = ESysECONNREFUSED;
WSAELOOP = ESysELOOP;
WSAENAMETOOLONG = ESysENAMETOOLONG;
WSAEHOSTDOWN = ESysEHOSTDOWN;
WSAEHOSTUNREACH = ESysEHOSTUNREACH;
WSAENOTEMPTY = ESysENOTEMPTY;
WSAEPROCLIM = -1;
WSAEUSERS = ESysEUSERS;
WSAEDQUOT = ESysEDQUOT;
WSAESTALE = ESysESTALE;
WSAEREMOTE = ESysEREMOTE;
WSASYSNOTREADY = -2;
WSAVERNOTSUPPORTED = -3;
WSANOTINITIALISED = -4;
WSAEDISCON = -5;
WSAHOST_NOT_FOUND = 1;
WSATRY_AGAIN = 2;
WSANO_RECOVERY = 3;
WSANO_DATA = -6;
const
WSADESCRIPTION_LEN = 256;
WSASYS_STATUS_LEN = 128;
type
PWSAData = ^TWSAData;
TWSAData = packed record
wVersion: Word;
wHighVersion: Word;
szDescription: array[0..WSADESCRIPTION_LEN] of Char;
szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
iMaxSockets: Word;
iMaxUdpDg: Word;
lpVendorInfo: PChar;
end;
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6):boolean;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
var
in6addr_any, in6addr_loopback : TInAddr6;
procedure FD_CLR(Socket: TSocket; var FDSet: TFDSet);
function FD_ISSET(Socket: TSocket; var FDSet: TFDSet): Boolean;
procedure FD_SET(Socket: TSocket; var FDSet: TFDSet);
procedure FD_ZERO(var FDSet: TFDSet);
{=============================================================================}
var
SynSockCS: SyncObjs.TCriticalSection;
SockEnhancedApi: Boolean;
SockWship6Api: Boolean;
type
TVarSin = packed record
{$ifdef SOCK_HAS_SINLEN}
sin_len : cuchar;
{$endif}
case integer of
0: (AddressFamily: sa_family_t);
1: (
case sin_family: sa_family_t of
AF_INET: (sin_port: word;
sin_addr: TInAddr;
sin_zero: array[0..7] of Char);
AF_INET6: (sin6_port: word;
sin6_flowinfo: longword;
sin6_addr: TInAddr6;
sin6_scope_id: longword);
);
end;
function SizeOfVarSin(sin: TVarSin): integer;
function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
function WSACleanup: Integer;
function WSAGetLastError: Integer;
function GetHostName: string;
function Shutdown(s: TSocket; how: Integer): Integer;
function SetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
optlen: Integer): Integer;
function GetSockOpt(s: TSocket; level, optname: Integer; optval: TMemory;
var optlen: Integer): Integer;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
function ntohs(netshort: word): word;
function ntohl(netlong: longword): longword;
function Listen(s: TSocket; backlog: Integer): Integer;
function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
function htons(hostshort: word): word;
function htonl(hostlong: longword): longword;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
function Connect(s: TSocket; const name: TVarSin): Integer;
function CloseSocket(s: TSocket): Integer;
function Bind(s: TSocket; const addr: TVarSin): Integer;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
function Socket(af, Struc, Protocol: Integer): TSocket;
function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint;
function IsNewApi(Family: integer): Boolean;
function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
function GetSinIP(Sin: TVarSin): string;
function GetSinPort(Sin: TVarSin): Integer;
procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings);
function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
{==============================================================================}
implementation
function IN6_IS_ADDR_UNSPECIFIED(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
(a^.u6_addr32[2] = 0) and (a^.u6_addr32[3] = 0));
end;
function IN6_IS_ADDR_LOOPBACK(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr32[0] = 0) and (a^.u6_addr32[1] = 0) and
(a^.u6_addr32[2] = 0) and
(a^.u6_addr8[12] = 0) and (a^.u6_addr8[13] = 0) and
(a^.u6_addr8[14] = 0) and (a^.u6_addr8[15] = 1));
end;
function IN6_IS_ADDR_LINKLOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $80));
end;
function IN6_IS_ADDR_SITELOCAL(const a: PInAddr6): boolean;
begin
Result := ((a^.u6_addr8[0] = $FE) and (a^.u6_addr8[1] = $C0));
end;
function IN6_IS_ADDR_MULTICAST(const a: PInAddr6): boolean;
begin
Result := (a^.u6_addr8[0] = $FF);
end;
function IN6_ADDR_EQUAL(const a: PInAddr6; const b: PInAddr6): boolean;
begin
Result := (CompareMem( a, b, sizeof(TInAddr6)));
end;
procedure SET_IN6_IF_ADDR_ANY (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
end;
procedure SET_LOOPBACK_ADDR6 (const a: PInAddr6);
begin
FillChar(a^, sizeof(TInAddr6), 0);
a^.u6_addr8[15] := 1;
end;
{=============================================================================}
function WSAStartup(wVersionRequired: Word; var WSData: TWSAData): Integer;
begin
with WSData do
begin
wVersion := wVersionRequired;
wHighVersion := $202;
szDescription := 'Synsock - Synapse Platform Independent Socket Layer';
szSystemStatus := 'Running on Unix/Linux by FreePascal';
iMaxSockets := 32768;
iMaxUdpDg := 8192;
end;
Result := 0;
end;
function WSACleanup: Integer;
begin
Result := 0;
end;
function WSAGetLastError: Integer;
begin
Result := fpGetErrno;
end;
function FD_ISSET(Socket: TSocket; var fdset: TFDSet): Boolean;
begin
Result := fpFD_ISSET(socket, fdset) <> 0;
end;
procedure FD_SET(Socket: TSocket; var fdset: TFDSet);
begin
fpFD_SET(Socket, fdset);
end;
procedure FD_CLR(Socket: TSocket; var fdset: TFDSet);
begin
fpFD_CLR(Socket, fdset);
end;
procedure FD_ZERO(var fdset: TFDSet);
begin
fpFD_ZERO(fdset);
end;
{=============================================================================}
function SizeOfVarSin(sin: TVarSin): integer;
begin
case sin.sin_family of
AF_INET:
Result := SizeOf(TSockAddrIn);
AF_INET6:
Result := SizeOf(TSockAddrIn6);
else
Result := 0;
end;
end;
{=============================================================================}
function Bind(s: TSocket; const addr: TVarSin): Integer;
begin
if fpBind(s, @addr, SizeOfVarSin(addr)) = 0 then
Result := 0
else
Result := SOCKET_ERROR;
end;
function Connect(s: TSocket; const name: TVarSin): Integer;
begin
if fpConnect(s, @name, SizeOfVarSin(name)) = 0 then
Result := 0
else
Result := SOCKET_ERROR;
end;
function GetSockName(s: TSocket; var name: TVarSin): Integer;
var
len: integer;
begin
len := SizeOf(name);
FillChar(name, len, 0);
Result := fpGetSockName(s, @name, @Len);
end;
function GetPeerName(s: TSocket; var name: TVarSin): Integer;
var
len: integer;
begin
len := SizeOf(name);
FillChar(name, len, 0);
Result := fpGetPeerName(s, @name, @Len);
end;
function GetHostName: string;
begin
Result := unix.GetHostName;
end;
function Send(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
begin
Result := fpSend(s, pointer(Buf), len, flags);
end;
function Recv(s: TSocket; Buf: TMemory; len, flags: Integer): Integer;
begin
Result := fpRecv(s, pointer(Buf), len, flags);
end;
function SendTo(s: TSocket; Buf: TMemory; len, flags: Integer; addrto: TVarSin): Integer;
begin
Result := fpSendTo(s, pointer(Buf), len, flags, @addrto, SizeOfVarSin(addrto));
end;
function RecvFrom(s: TSocket; Buf: TMemory; len, flags: Integer; var from: TVarSin): Integer;
var
x: integer;
begin
x := SizeOf(from);
Result := fpRecvFrom(s, pointer(Buf), len, flags, @from, @x);
end;
function Accept(s: TSocket; var addr: TVarSin): TSocket;
var
x: integer;
begin
x := SizeOf(addr);
Result := fpAccept(s, @addr, @x);
end;
function Shutdown(s: TSocket; how: Integer): Integer;
begin
Result := fpShutdown(s, how);
end;
function SetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
optlen: Integer): Integer;
begin
Result := fpsetsockopt(s, level, optname, pointer(optval), optlen);
end;
function GetSockOpt(s: TSocket; level, optname: Integer; optval: Tmemory;
var optlen: Integer): Integer;
begin
Result := fpgetsockopt(s, level, optname, pointer(optval), @optlen);
end;
function ntohs(netshort: word): word;
begin
Result := sockets.ntohs(NetShort);
end;
function ntohl(netlong: longword): longword;
begin
Result := sockets.ntohl(NetLong);
end;
function Listen(s: TSocket; backlog: Integer): Integer;
begin
if fpListen(s, backlog) = 0 then
Result := 0
else
Result := SOCKET_ERROR;
end;
function IoctlSocket(s: TSocket; cmd: DWORD; var arg: integer): Integer;
begin
Result := fpIoctl(s, cmd, @arg);
end;
function htons(hostshort: word): word;
begin
Result := sockets.htons(Hostshort);
end;
function htonl(hostlong: longword): longword;
begin
Result := sockets.htonl(HostLong);
end;
function CloseSocket(s: TSocket): Integer;
begin
Result := sockets.CloseSocket(s);
end;
function Socket(af, Struc, Protocol: Integer): TSocket;
begin
Result := fpSocket(af, struc, protocol);
end;
function Select(nfds: Integer; readfds, writefds, exceptfds: PFDSet;
timeout: PTimeVal): Longint;
begin
Result := fpSelect(nfds, readfds, writefds, exceptfds, timeout);
end;
{=============================================================================}
function IsNewApi(Family: integer): Boolean;
begin
Result := SockEnhancedApi;
if not Result then
Result := (Family = AF_INET6) and SockWship6Api;
end;
function SetVarSin(var Sin: TVarSin; IP, Port: string; Family, SockProtocol, SockType: integer; PreferIP4: Boolean): integer;
var
TwoPass: boolean;
f1, f2: integer;
function GetAddr(f:integer): integer;
var
a4: array [1..1] of in_addr;
a6: array [1..1] of Tin6_addr;
he: THostEntry;
begin
Result := WSAEPROTONOSUPPORT;
case f of
AF_INET:
begin
if IP = cAnyHost then
begin
Sin.sin_family := AF_INET;
Result := 0;
end
else
begin
if lowercase(IP) = cLocalHostStr then
a4[1].s_addr := htonl(INADDR_LOOPBACK)
else
begin
a4[1].s_addr := 0;
Result := WSAHOST_NOT_FOUND;
a4[1] := StrTonetAddr(IP);
if a4[1].s_addr = INADDR_ANY then
if GetHostByName(ip, he) then
a4[1]:=HostToNet(he.Addr)
else
Resolvename(ip, a4);
end;
if a4[1].s_addr <> INADDR_ANY then
begin
Sin.sin_family := AF_INET;
sin.sin_addr := a4[1];
Result := 0;
end;
end;
end;
AF_INET6:
begin
if IP = c6AnyHost then
begin
Sin.sin_family := AF_INET6;
Result := 0;
end
else
begin
if lowercase(IP) = cLocalHostStr then
SET_LOOPBACK_ADDR6(@a6[1])
else
begin
Result := WSAHOST_NOT_FOUND;
SET_IN6_IF_ADDR_ANY(@a6[1]);
a6[1] := StrTonetAddr6(IP);
if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
Resolvename6(ip, a6);
end;
if not IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
begin
Sin.sin_family := AF_INET6;
sin.sin6_addr := a6[1];
Result := 0;
end;
end;
end;
end;
end;
begin
Result := 0;
FillChar(Sin, Sizeof(Sin), 0);
Sin.sin_port := Resolveport(port, family, SockProtocol, SockType);
TwoPass := False;
if Family = AF_UNSPEC then
begin
if PreferIP4 then
begin
f1 := AF_INET;
f2 := AF_INET6;
TwoPass := True;
end
else
begin
f2 := AF_INET;
f1 := AF_INET6;
TwoPass := True;
end;
end
else
f1 := Family;
Result := GetAddr(f1);
if Result <> 0 then
if TwoPass then
Result := GetAddr(f2);
end;
function GetSinIP(Sin: TVarSin): string;
begin
Result := '';
case sin.AddressFamily of
AF_INET:
begin
result := NetAddrToStr(sin.sin_addr);
end;
AF_INET6:
begin
result := NetAddrToStr6(sin.sin6_addr);
end;
end;
end;
function GetSinPort(Sin: TVarSin): Integer;
begin
if (Sin.sin_family = AF_INET6) then
Result := synsock.ntohs(Sin.sin6_port)
else
Result := synsock.ntohs(Sin.sin_port);
end;
procedure ResolveNameToIP(Name: string; Family, SockProtocol, SockType: integer; const IPList: TStrings);
var
x, n: integer;
a4: array [1..255] of in_addr;
a6: array [1..255] of Tin6_addr;
he: THostEntry;
begin
IPList.Clear;
if (family = AF_INET) or (family = AF_UNSPEC) then
begin
if lowercase(name) = cLocalHostStr then
IpList.Add(cLocalHost)
else
begin
a4[1] := StrTonetAddr(name);
if a4[1].s_addr = INADDR_ANY then
if GetHostByName(name, he) then
begin
a4[1]:=HostToNet(he.Addr);
x := 1;
end
else
x := Resolvename(name, a4)
else
x := 1;
for n := 1 to x do
IpList.Add(netaddrToStr(a4[n]));
end;
end;
if (family = AF_INET6) or (family = AF_UNSPEC) then
begin
if lowercase(name) = cLocalHostStr then
IpList.Add(c6LocalHost)
else
begin
a6[1] := StrTonetAddr6(name);
if IN6_IS_ADDR_UNSPECIFIED(@a6[1]) then
x := Resolvename6(name, a6)
else
x := 1;
for n := 1 to x do
IpList.Add(netaddrToStr6(a6[n]));
end;
end;
if IPList.Count = 0 then
IPList.Add(cLocalHost);
end;
function ResolvePort(Port: string; Family, SockProtocol, SockType: integer): Word;
var
ProtoEnt: TProtocolEntry;
ServEnt: TServiceEntry;
begin
Result := synsock.htons(StrToIntDef(Port, 0));
if Result = 0 then
begin
ProtoEnt.Name := '';
GetProtocolByNumber(SockProtocol, ProtoEnt);
ServEnt.port := 0;
GetServiceByName(Port, ProtoEnt.Name, ServEnt);
Result := ServEnt.port;
end;
end;
function ResolveIPToName(IP: string; Family, SockProtocol, SockType: integer): string;
var
n: integer;
a4: array [1..1] of in_addr;
a6: array [1..1] of Tin6_addr;
a: array [1..1] of string;
begin
Result := IP;
a4[1] := StrToNetAddr(IP);
if a4[1].s_addr <> INADDR_ANY then
begin
//why ResolveAddress need address in HOST order? :-O
n := ResolveAddress(nettohost(a4[1]), a);
if n > 0 then
Result := a[1];
end
else
begin
a6[1] := StrToNetAddr6(IP);
n := ResolveAddress6(a6[1], a);
if n > 0 then
Result := a[1];
end;
end;
{=============================================================================}
function InitSocketInterface(stack: string): Boolean;
begin
SockEnhancedApi := False;
SockWship6Api := False;
// Libc.Signal(Libc.SIGPIPE, TSignalHandler(Libc.SIG_IGN));
Result := True;
end;
function DestroySocketInterface: Boolean;
begin
Result := True;
end;
initialization
begin
SynSockCS := SyncObjs.TCriticalSection.Create;
SET_IN6_IF_ADDR_ANY (@in6addr_any);
SET_LOOPBACK_ADDR6 (@in6addr_loopback);
end;
finalization
begin
SynSockCS.Free;
end;
{$ENDIF}

677
synapse/ssl_cryptlib.pas Normal file
View File

@ -0,0 +1,677 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.000 |
|==============================================================================|
| Content: SSL/SSH support by Peter Gutmann's CryptLib |
|==============================================================================|
| Copyright (c)1999-2012, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SSL/SSH plugin for CryptLib)
This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32
and Linux. This library is staticly linked - when you compile your application
with this plugin, you MUST distribute it with Cryptib library, otherwise you
cannot run your application!
It can work with keys and certificates stored as PKCS#15 only! It must be stored
as disk file only, you cannot load them from memory! Each file can hold multiple
keys and certificates. You must identify it by 'label' stored in
@link(TSSLCryptLib.PrivateKeyLabel).
If you need to use secure connection and authorize self by certificate
(each SSL/TLS server or client with client authorization), then use
@link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and
@link(TCustomSSL.KeyPassword) properties.
If you need to use server what verifying client certificates, then use
@link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients
with non-matching certificates will be rejected by cryptLib.
This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
server without explicitly assigned key and certificate, then this plugin create
Ad-Hoc key and certificate for each incomming connection by self. It slowdown
accepting of new connections!
You can use this plugin for SSHv2 connections too! You must explicitly set
@link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username)
and @link(TCustomSSL.password). You can use special SSH channels too, see
@link(TCustomSSL).
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ssl_cryptlib;
interface
uses
Windows,
SysUtils,
blcksock, synsock, synautil, synacode,
cryptlib;
type
{:@abstract(class implementing CryptLib SSL/SSH plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLCryptLib = class(TCustomSSL)
protected
FCryptSession: CRYPT_SESSION;
FPrivateKeyLabel: string;
FDelCert: Boolean;
FReadBuffer: string;
FTrustedCAs: array of integer;
function SSLCheck(Value: integer): Boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
function CreateSelfSignedCert(Host: string): Boolean; override;
function PopAll: string;
public
{:See @inherited}
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:Load trusted CA's in PEM format}
procedure SetCertCAFile(const Value: string); override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited}
procedure Assign(const Value: TCustomSSL); override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetVerifyCert: integer; override;
published
{:name of certificate/key within PKCS#15 file. It can hold more then one
certificate/key and each certificate/key must have unique label within one file.}
property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel;
end;
implementation
{==============================================================================}
constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
FPrivateKeyLabel := 'synapse';
FDelCert := false;
FTrustedCAs := nil;
end;
destructor TSSLCryptLib.Destroy;
begin
SetCertCAFile(''); // destroy certificates
DeInit;
inherited Destroy;
end;
procedure TSSLCryptLib.Assign(const Value: TCustomSSL);
begin
inherited Assign(Value);
if Value is TSSLCryptLib then
begin
FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel;
end;
end;
function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string;
var
l: integer;
begin
l := 0;
cryptGetAttributeString(cryptHandle, attributeType, nil, l);
setlength(Result, l);
cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l);
setlength(Result, l);
end;
function TSSLCryptLib.LibVersion: String;
var
x: integer;
begin
Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION);
cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x);
Result := Result + ' v' + IntToStr(x);
cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x);
Result := Result + '.' + IntToStr(x);
cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x);
Result := Result + '.' + IntToStr(x);
end;
function TSSLCryptLib.LibName: String;
begin
Result := 'ssl_cryptlib';
end;
function TSSLCryptLib.SSLCheck(Value: integer): Boolean;
begin
Result := true;
FLastErrorDesc := '';
if Value = CRYPT_ERROR_COMPLETE then
Value := 0;
FLastError := Value;
if FLastError <> 0 then
begin
Result := False;
{$IF CRYPTLIB_VERSION >= 3400}
FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_ERRORMESSAGE);
{$ELSE}
FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE);
{$IFEND}
end;
end;
function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean;
var
privateKey: CRYPT_CONTEXT;
keyset: CRYPT_KEYSET;
cert: CRYPT_CERTIFICATE;
publicKey: CRYPT_CONTEXT;
begin
if FPrivatekeyFile = '' then
FPrivatekeyFile := GetTempFile('', 'key');
cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA);
cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel),
Length(FPrivatekeyLabel));
cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024);
cryptGenerateKey(privateKey);
cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE);
FDelCert := True;
cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword));
cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE);
cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1);
cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel));
cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey);
cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host));
cryptSignCert(cert, privateKey);
cryptAddPublicKey(keyset, cert);
cryptKeysetClose(keyset);
cryptDestroyCert(cert);
cryptDestroyContext(privateKey);
cryptDestroyContext(publicKey);
Result := True;
end;
function TSSLCryptLib.PopAll: string;
const
BufferMaxSize = 32768;
var
Outbuffer: string;
WriteLen: integer;
begin
Result := '';
repeat
setlength(outbuffer, BufferMaxSize);
Writelen := 0;
SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen));
if FLastError <> 0 then
Break;
if WriteLen > 0 then
begin
setlength(outbuffer, WriteLen);
Result := Result + outbuffer;
end;
until WriteLen = 0;
end;
function TSSLCryptLib.Init(server:Boolean): Boolean;
var
st: CRYPT_SESSION_TYPE;
keysetobj: CRYPT_KEYSET;
cryptContext: CRYPT_CONTEXT;
x: integer;
begin
Result := False;
FLastErrorDesc := '';
FLastError := 0;
FDelCert := false;
FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
if server then
case FSSLType of
LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
st := CRYPT_SESSION_SSL_SERVER;
LT_SSHv2:
st := CRYPT_SESSION_SSH_SERVER;
else
Exit;
end
else
case FSSLType of
LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1:
st := CRYPT_SESSION_SSL;
LT_SSHv2:
st := CRYPT_SESSION_SSH;
else
Exit;
end;
if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then
Exit;
x := -1;
case FSSLType of
LT_SSLv3:
x := 0;
LT_TLSv1:
x := 1;
LT_TLSv1_1:
x := 2;
end;
if x >= 0 then
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then
Exit;
if (FCertComplianceLevel <> -1) then
if not SSLCheck(cryptSetAttribute (CRYPT_UNUSED, CRYPT_OPTION_CERT_COMPLIANCELEVEL,
FCertComplianceLevel)) then
Exit;
if FUsername <> '' then
begin
cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME,
Pointer(FUsername), Length(FUsername));
cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD,
Pointer(FPassword), Length(FPassword));
end;
if FSSLType = LT_SSHv2 then
if FSSHChannelType <> '' then
begin
cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED);
cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE,
Pointer(FSSHChannelType), Length(FSSHChannelType));
if FSSHChannelArg1 <> '' then
cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1,
Pointer(FSSHChannelArg1), Length(FSSHChannelArg1));
if FSSHChannelArg2 <> '' then
cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2,
Pointer(FSSHChannelArg2), Length(FSSHChannelArg2));
end;
if server and (FPrivatekeyFile = '') then
begin
if FPrivatekeyLabel = '' then
FPrivatekeyLabel := 'synapse';
if FkeyPassword = '' then
FkeyPassword := 'synapse';
CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
end;
if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then
begin
if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then
Exit;
try
if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME,
PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then
Exit;
if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY,
cryptcontext)) then
Exit;
finally
cryptKeysetClose(keySetObj);
cryptDestroyContext(cryptcontext);
end;
end;
if server and FVerifyCert then
begin
if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE,
PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then
Exit;
try
if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET,
keySetObj)) then
Exit;
finally
cryptKeysetClose(keySetObj);
end;
end;
Result := true;
end;
function TSSLCryptLib.DeInit: Boolean;
begin
Result := True;
if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
CryptDestroySession(FcryptSession);
FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE);
FSSLEnabled := False;
if FDelCert then
SysUtils.DeleteFile(FPrivatekeyFile);
end;
function TSSLCryptLib.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLCryptLib.Connect: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(false) then
begin
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
Exit;
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
Exit;
if FverifyCert then
if (GetVerifyCert <> 0) or (not DoVerifyCert) then
Exit;
FSSLEnabled := True;
Result := True;
FReadBuffer := '';
end;
end;
function TSSLCryptLib.Accept: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(true) then
begin
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then
Exit;
if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then
Exit;
FSSLEnabled := True;
Result := True;
FReadBuffer := '';
end;
end;
function TSSLCryptLib.Shutdown: boolean;
begin
Result := BiShutdown;
end;
function TSSLCryptLib.BiShutdown: boolean;
begin
if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then
cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0);
DeInit;
FReadBuffer := '';
Result := True;
end;
function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
FLastError := 0;
FLastErrorDesc := '';
SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L));
cryptFlushData(FcryptSession);
Result := l;
end;
function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
begin
FLastError := 0;
FLastErrorDesc := '';
if Length(FReadBuffer) = 0 then
FReadBuffer := PopAll;
if Len > Length(FReadBuffer) then
Len := Length(FReadBuffer);
Move(Pointer(FReadBuffer)^, buffer^, Len);
Delete(FReadBuffer, 1, Len);
Result := Len;
end;
function TSSLCryptLib.WaitingData: Integer;
begin
Result := Length(FReadBuffer);
end;
function TSSLCryptLib.GetSSLVersion: string;
var
x: integer;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x);
if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then
case x of
0:
Result := 'SSLv3';
1:
Result := 'TLSv1';
2:
Result := 'TLSv1.1';
end;
if FSSLType in [LT_SSHv2] then
case x of
0:
Result := 'SSHv1';
1:
Result := 'SSHv2';
end;
end;
function TSSLCryptLib.GetPeerSubject: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
Result := GetString(cert, CRYPT_CERTINFO_DN);
cryptDestroyCert(cert);
end;
function TSSLCryptLib.GetPeerName: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
cryptDestroyCert(cert);
end;
function TSSLCryptLib.GetPeerIssuer: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_ISSUERNAME);
Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME);
cryptDestroyCert(cert);
end;
function TSSLCryptLib.GetPeerFingerprint: string;
var
cert: CRYPT_CERTIFICATE;
begin
Result := '';
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT);
cryptDestroyCert(cert);
end;
procedure TSSLCryptLib.SetCertCAFile(const Value: string);
var F:textfile;
bInCert:boolean;
s,sCert:string;
cert: CRYPT_CERTIFICATE;
idx:integer;
begin
if assigned(FTrustedCAs) then
begin
for idx := 0 to High(FTrustedCAs) do
cryptDestroyCert(FTrustedCAs[idx]);
FTrustedCAs:=nil;
end;
if Value<>'' then
begin
AssignFile(F,Value);
reset(F);
bInCert:=false;
idx:=0;
while not eof(F) do
begin
readln(F,s);
if pos('-----END CERTIFICATE-----',s)>0 then
begin
bInCert:=false;
cert:=0;
if (cryptImportCert(PAnsiChar(sCert),length(sCert)-2,CRYPT_UNUSED,cert)=CRYPT_OK) then
begin
cryptSetAttribute( cert, CRYPT_CERTINFO_TRUSTED_IMPLICIT, 1 );
SetLength(FTrustedCAs,idx+1);
FTrustedCAs[idx]:=cert;
idx:=idx+1;
end;
end;
if bInCert then
sCert:=sCert+s+#13#10;
if pos('-----BEGIN CERTIFICATE-----',s)>0 then
begin
bInCert:=true;
sCert:='';
end;
end;
CloseFile(F);
end;
end;
function TSSLCryptLib.GetVerifyCert: integer;
var
cert: CRYPT_CERTIFICATE;
itype,ilocus:integer;
begin
Result := -1;
if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then
Exit;
cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert);
result:=cryptCheckCert(cert,CRYPT_UNUSED);
if result<>CRYPT_OK then
begin
//get extended error info if available
cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORtype,itype);
cryptGetAttribute(cert,CRYPT_ATTRIBUTE_ERRORLOCUS,ilocus);
cryptSetAttribute(cert, CRYPT_ATTRIBUTE_CURRENT, CRYPT_CERTINFO_SUBJECTNAME);
FLastError := Result;
FLastErrorDesc := format('SSL/TLS certificate verification failed for "%s"'#13#10'Status: %d. ERRORTYPE: %d. ERRORLOCUS: %d.',
[GetString(cert, CRYPT_CERTINFO_COMMONNAME),result,itype,ilocus]);
end;
cryptDestroyCert(cert);
end;
{==============================================================================}
var imajor,iminor,iver:integer;
// e: ESynapseError;
initialization
if cryptInit = CRYPT_OK then
SSLImplementation := TSSLCryptLib;
cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL);
cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION,imajor);
cryptGetAttribute (CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION,iminor);
// according to the documentation CRYPTLIB version has 3 digits. recent versions use 4 digits
if CRYPTLIB_VERSION >1000 then
iver:=CRYPTLIB_VERSION div 100
else
iver:=CRYPTLIB_VERSION div 10;
if (iver <> imajor*10+iminor) then
begin
SSLImplementation :=TSSLNone;
// e := ESynapseError.Create(format('Error wrong cryptlib version (is %d.%d expected %d.%d). ',
// [imajor,iminor,iver div 10, iver mod 10]));
// e.ErrorCode := 0;
// e.ErrorMessage := format('Error wrong cryptlib version (%d.%d expected %d.%d)',
// [imajor,iminor,iver div 10, iver mod 10]);
// raise e;
end;
finalization
cryptEnd;
end.

896
synapse/ssl_openssl.pas Normal file
View File

@ -0,0 +1,896 @@
{==============================================================================|
| Project : Ararat Synapse | 001.002.000 |
|==============================================================================|
| Content: SSL support by OpenSSL |
|==============================================================================|
| Copyright (c)1999-2008, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005-2012. |
| Portions created by Petr Fejfar are Copyright (c)2011-2012. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
//requires OpenSSL libraries!
{:@abstract(SSL plugin for OpenSSL)
You need OpenSSL libraries version 0.9.7. It can work with 0.9.6 too, but
application mysteriously crashing when you are using freePascal on Linux.
Use Kylix on Linux is OK! If you have version 0.9.7 on Linux, then I not see
any problems with FreePascal.
OpenSSL libraries are loaded dynamicly - you not need OpenSSl librares even you
compile your application with this unit. SSL just not working when you not have
OpenSSL libraries.
This plugin have limited support for .NET too! Because is not possible to use
callbacks with CDECL calling convention under .NET, is not supported
key/certificate passwords and multithread locking. :-(
For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertificateFile) for PEM or ASN1 DER (cer) format. @br
@link(TCustomSSL.Certificate) for ASN1 DER format only. @br
@link(TCustomSSL.PrivateKeyFile) for PEM or ASN1 DER (key) format. @br
@link(TCustomSSL.PrivateKey) for ASN1 DER format only. @br
@link(TCustomSSL.CertCAFile) for PEM CA certificate bundle. @br
@link(TCustomSSL.PFXFile) for PFX format. @br
@link(TCustomSSL.PFX) for PFX format from binary string. @br
This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS
server without explicitly assigned key and certificate, then this plugin create
Ad-Hoc key and certificate for each incomming connection by self. It slowdown
accepting of new connections!
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit ssl_openssl;
interface
uses
SysUtils, Classes,
blcksock, synsock, synautil,
{$IFDEF CIL}
System.Text,
{$ENDIF}
ssl_openssl_lib;
type
{:@abstract(class implementing OpenSSL SSL plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLOpenSSL = class(TCustomSSL)
protected
FSsl: PSSL;
Fctx: PSSL_CTX;
function SSLCheck: Boolean;
function SetSslKeys: boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
function LoadPFX(pfxdata: ansistring): Boolean;
function CreateSelfSignedCert(Host: string): Boolean; override;
public
{:See @inherited}
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_cryptlib) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerSerialNo: integer; override; {pf}
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerNameHash: cardinal; override; {pf}
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
{:See @inherited}
function GetCipherName: string; override;
{:See @inherited}
function GetCipherBits: integer; override;
{:See @inherited}
function GetCipherAlgBits: integer; override;
{:See @inherited}
function GetVerifyCert: integer; override;
end;
implementation
{==============================================================================}
{$IFNDEF CIL}
function PasswordCallback(buf:PAnsiChar; size:Integer; rwflag:Integer; userdata: Pointer):Integer; cdecl;
var
Password: AnsiString;
begin
Password := '';
if TCustomSSL(userdata) is TCustomSSL then
Password := TCustomSSL(userdata).KeyPassword;
if Length(Password) > (Size - 1) then
SetLength(Password, Size - 1);
Result := Length(Password);
StrLCopy(buf, PAnsiChar(Password + #0), Result + 1);
end;
{$ENDIF}
{==============================================================================}
constructor TSSLOpenSSL.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FCiphers := 'DEFAULT';
FSsl := nil;
Fctx := nil;
end;
destructor TSSLOpenSSL.Destroy;
begin
DeInit;
inherited Destroy;
end;
function TSSLOpenSSL.LibVersion: String;
begin
Result := SSLeayversion(0);
end;
function TSSLOpenSSL.LibName: String;
begin
Result := 'ssl_openssl';
end;
function TSSLOpenSSL.SSLCheck: Boolean;
var
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
s : AnsiString;
begin
Result := true;
FLastErrorDesc := '';
FLastError := ErrGetError;
ErrClearError;
if FLastError <> 0 then
begin
Result := False;
{$IFDEF CIL}
sb := StringBuilder.Create(256);
ErrErrorString(FLastError, sb, 256);
FLastErrorDesc := Trim(sb.ToString);
{$ELSE}
s := StringOfChar(#0, 256);
ErrErrorString(FLastError, s, Length(s));
FLastErrorDesc := s;
{$ENDIF}
end;
end;
function TSSLOpenSSL.CreateSelfSignedCert(Host: string): Boolean;
var
pk: EVP_PKEY;
x: PX509;
rsa: PRSA;
t: PASN1_UTCTIME;
name: PX509_NAME;
b: PBIO;
xn, y: integer;
s: AnsiString;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
Result := True;
pk := EvpPkeynew;
x := X509New;
try
rsa := RsaGenerateKey(1024, $10001, nil, nil);
EvpPkeyAssign(pk, EVP_PKEY_RSA, rsa);
X509SetVersion(x, 2);
Asn1IntegerSet(X509getSerialNumber(x), 0);
t := Asn1UtctimeNew;
try
X509GmtimeAdj(t, -60 * 60 *24);
X509SetNotBefore(x, t);
X509GmtimeAdj(t, 60 * 60 * 60 *24);
X509SetNotAfter(x, t);
finally
Asn1UtctimeFree(t);
end;
X509SetPubkey(x, pk);
Name := X509GetSubjectName(x);
X509NameAddEntryByTxt(Name, 'C', $1001, 'CZ', -1, -1, 0);
X509NameAddEntryByTxt(Name, 'CN', $1001, host, -1, -1, 0);
x509SetIssuerName(x, Name);
x509Sign(x, pk, EvpGetDigestByName('SHA1'));
b := BioNew(BioSMem);
try
i2dX509Bio(b, x);
xn := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(xn);
y := bioread(b, sb, xn);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s, xn);
y := bioread(b, s, xn);
if y > 0 then
setlength(s, y);
{$ENDIF}
finally
BioFreeAll(b);
end;
FCertificate := s;
b := BioNew(BioSMem);
try
i2dPrivatekeyBio(b, pk);
xn := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(xn);
y := bioread(b, sb, xn);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s, xn);
y := bioread(b, s, xn);
if y > 0 then
setlength(s, y);
{$ENDIF}
finally
BioFreeAll(b);
end;
FPrivatekey := s;
finally
X509free(x);
EvpPkeyFree(pk);
end;
end;
function TSSLOpenSSL.LoadPFX(pfxdata: Ansistring): Boolean;
var
cert, pkey, ca: SslPtr;
b: PBIO;
p12: SslPtr;
begin
Result := False;
b := BioNew(BioSMem);
try
BioWrite(b, pfxdata, Length(PfxData));
p12 := d2iPKCS12bio(b, nil);
if not Assigned(p12) then
Exit;
try
cert := nil;
pkey := nil;
ca := nil;
try {pf}
if PKCS12parse(p12, FKeyPassword, pkey, cert, ca) > 0 then
if SSLCTXusecertificate(Fctx, cert) > 0 then
if SSLCTXusePrivateKey(Fctx, pkey) > 0 then
Result := True;
{pf}
finally
EvpPkeyFree(pkey);
X509free(cert);
SkX509PopFree(ca,_X509Free); // for ca=nil a new STACK was allocated...
end;
{/pf}
finally
PKCS12free(p12);
end;
finally
BioFreeAll(b);
end;
end;
function TSSLOpenSSL.SetSslKeys: boolean;
var
st: TFileStream;
s: string;
begin
Result := False;
if not assigned(FCtx) then
Exit;
try
if FCertificateFile <> '' then
if SslCtxUseCertificateChainFile(FCtx, FCertificateFile) <> 1 then
if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_PEM) <> 1 then
if SslCtxUseCertificateFile(FCtx, FCertificateFile, SSL_FILETYPE_ASN1) <> 1 then
Exit;
if FCertificate <> '' then
if SslCtxUseCertificateASN1(FCtx, length(FCertificate), FCertificate) <> 1 then
Exit;
SSLCheck;
if FPrivateKeyFile <> '' then
if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_PEM) <> 1 then
if SslCtxUsePrivateKeyFile(FCtx, FPrivateKeyFile, SSL_FILETYPE_ASN1) <> 1 then
Exit;
if FPrivateKey <> '' then
if SslCtxUsePrivateKeyASN1(EVP_PKEY_RSA, FCtx, FPrivateKey, length(FPrivateKey)) <> 1 then
Exit;
SSLCheck;
if FCertCAFile <> '' then
if SslCtxLoadVerifyLocations(FCtx, FCertCAFile, '') <> 1 then
Exit;
if FPFXfile <> '' then
begin
try
st := TFileStream.Create(FPFXfile, fmOpenRead or fmShareDenyNone);
try
s := ReadStrFromStream(st, st.Size);
finally
st.Free;
end;
if not LoadPFX(s) then
Exit;
except
on Exception do
Exit;
end;
end;
if FPFX <> '' then
if not LoadPFX(FPfx) then
Exit;
SSLCheck;
Result := True;
finally
SSLCheck;
end;
end;
function TSSLOpenSSL.Init(server:Boolean): Boolean;
var
s: AnsiString;
begin
Result := False;
FLastErrorDesc := '';
FLastError := 0;
Fctx := nil;
case FSSLType of
LT_SSLv2:
Fctx := SslCtxNew(SslMethodV2);
LT_SSLv3:
Fctx := SslCtxNew(SslMethodV3);
LT_TLSv1:
Fctx := SslCtxNew(SslMethodTLSV1);
LT_all:
Fctx := SslCtxNew(SslMethodV23);
else
Exit;
end;
if Fctx = nil then
begin
SSLCheck;
Exit;
end
else
begin
s := FCiphers;
SslCtxSetCipherList(Fctx, s);
if FVerifyCert then
SslCtxSetVerify(FCtx, SSL_VERIFY_PEER, nil)
else
SslCtxSetVerify(FCtx, SSL_VERIFY_NONE, nil);
{$IFNDEF CIL}
SslCtxSetDefaultPasswdCb(FCtx, @PasswordCallback);
SslCtxSetDefaultPasswdCbUserdata(FCtx, self);
{$ENDIF}
if server and (FCertificateFile = '') and (FCertificate = '')
and (FPFXfile = '') and (FPFX = '') then
begin
CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP));
end;
if not SetSSLKeys then
Exit
else
begin
Fssl := nil;
Fssl := SslNew(Fctx);
if Fssl = nil then
begin
SSLCheck;
exit;
end;
end;
end;
Result := true;
end;
function TSSLOpenSSL.DeInit: Boolean;
begin
Result := True;
if assigned (Fssl) then
sslfree(Fssl);
Fssl := nil;
if assigned (Fctx) then
begin
SslCtxFree(Fctx);
Fctx := nil;
ErrRemoveState(0);
end;
FSSLEnabled := False;
end;
function TSSLOpenSSL.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLOpenSSL.Connect: boolean;
var
x: integer;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(False) then
begin
{$IFDEF CIL}
if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
{$ELSE}
if sslsetfd(FSsl, FSocket.Socket) < 1 then
{$ENDIF}
begin
SSLCheck;
Exit;
end;
if SNIHost<>'' then
SSLCtrl(Fssl, SSL_CTRL_SET_TLSEXT_HOSTNAME, TLSEXT_NAMETYPE_host_name, PAnsiChar(SNIHost));
x := sslconnect(FSsl);
if x < 1 then
begin
SSLcheck;
Exit;
end;
if FverifyCert then
if (GetVerifyCert <> 0) or (not DoVerifyCert) then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLOpenSSL.Accept: boolean;
var
x: integer;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(True) then
begin
{$IFDEF CIL}
if sslsetfd(FSsl, FSocket.Socket.Handle.ToInt32) < 1 then
{$ELSE}
if sslsetfd(FSsl, FSocket.Socket) < 1 then
{$ENDIF}
begin
SSLCheck;
Exit;
end;
x := sslAccept(FSsl);
if x < 1 then
begin
SSLcheck;
Exit;
end;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLOpenSSL.Shutdown: boolean;
begin
if assigned(FSsl) then
sslshutdown(FSsl);
DeInit;
Result := True;
end;
function TSSLOpenSSL.BiShutdown: boolean;
var
x: integer;
begin
if assigned(FSsl) then
begin
x := sslshutdown(FSsl);
if x = 0 then
begin
Synsock.Shutdown(FSocket.Socket, 1);
sslshutdown(FSsl);
end;
end;
DeInit;
Result := True;
end;
function TSSLOpenSSL.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
err: integer;
{$IFDEF CIL}
s: ansistring;
{$ENDIF}
begin
FLastError := 0;
FLastErrorDesc := '';
repeat
{$IFDEF CIL}
s := StringOf(Buffer);
Result := SslWrite(FSsl, s, Len);
{$ELSE}
Result := SslWrite(FSsl, Buffer , Len);
{$ENDIF}
err := SslGetError(FSsl, Result);
until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
if err = SSL_ERROR_ZERO_RETURN then
Result := 0
else
if (err <> 0) then
FLastError := err;
end;
function TSSLOpenSSL.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
err: integer;
{$IFDEF CIL}
sb: stringbuilder;
s: ansistring;
{$ENDIF}
begin
FLastError := 0;
FLastErrorDesc := '';
repeat
{$IFDEF CIL}
sb := StringBuilder.Create(Len);
Result := SslRead(FSsl, sb, Len);
if Result > 0 then
begin
sb.Length := Result;
s := sb.ToString;
System.Array.Copy(BytesOf(s), Buffer, length(s));
end;
{$ELSE}
Result := SslRead(FSsl, Buffer , Len);
{$ENDIF}
err := SslGetError(FSsl, Result);
until (err <> SSL_ERROR_WANT_READ) and (err <> SSL_ERROR_WANT_WRITE);
if err = SSL_ERROR_ZERO_RETURN then
Result := 0
{pf}// Verze 1.1.0 byla s else tak jak to ted mam,
// ve verzi 1.1.1 bylo ELSE zruseno, ale pak je SSL_ERROR_ZERO_RETURN
// propagovano jako Chyba.
{pf} else {/pf} if (err <> 0) then
FLastError := err;
end;
function TSSLOpenSSL.WaitingData: Integer;
begin
Result := sslpending(Fssl);
end;
function TSSLOpenSSL.GetSSLVersion: string;
begin
if not assigned(FSsl) then
Result := ''
else
Result := SSlGetVersion(FSsl);
end;
function TSSLOpenSSL.GetPeerSubject: string;
var
cert: PX509;
s: ansistring;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
{$IFDEF CIL}
sb := StringBuilder.Create(4096);
Result := X509NameOneline(X509GetSubjectName(cert), sb, 4096);
{$ELSE}
setlength(s, 4096);
Result := X509NameOneline(X509GetSubjectName(cert), s, Length(s));
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetPeerSerialNo: integer; {pf}
var
cert: PX509;
SN: PASN1_INTEGER;
begin
if not assigned(FSsl) then
begin
Result := -1;
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
try
if not assigned(cert) then
begin
Result := -1;
Exit;
end;
SN := X509GetSerialNumber(cert);
Result := Asn1IntegerGet(SN);
finally
X509Free(cert);
end;
end;
function TSSLOpenSSL.GetPeerName: string;
var
s: ansistring;
begin
s := GetPeerSubject;
s := SeparateRight(s, '/CN=');
Result := Trim(SeparateLeft(s, '/'));
end;
function TSSLOpenSSL.GetPeerNameHash: cardinal; {pf}
var
cert: PX509;
begin
if not assigned(FSsl) then
begin
Result := 0;
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
try
if not assigned(cert) then
begin
Result := 0;
Exit;
end;
Result := X509NameHash(X509GetSubjectName(cert));
finally
X509Free(cert);
end;
end;
function TSSLOpenSSL.GetPeerIssuer: string;
var
cert: PX509;
s: ansistring;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
{$IFDEF CIL}
sb := StringBuilder.Create(4096);
Result := X509NameOneline(X509GetIssuerName(cert), sb, 4096);
{$ELSE}
setlength(s, 4096);
Result := X509NameOneline(X509GetIssuerName(cert), s, Length(s));
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetPeerFingerprint: string;
var
cert: PX509;
x: integer;
{$IFDEF CIL}
sb: StringBuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
{$IFDEF CIL}
sb := StringBuilder.Create(EVP_MAX_MD_SIZE);
X509Digest(cert, EvpGetDigestByName('MD5'), sb, x);
sb.Length := x;
Result := sb.ToString;
{$ELSE}
setlength(Result, EVP_MAX_MD_SIZE);
X509Digest(cert, EvpGetDigestByName('MD5'), Result, x);
SetLength(Result, x);
{$ENDIF}
X509Free(cert);
end;
function TSSLOpenSSL.GetCertInfo: string;
var
cert: PX509;
x, y: integer;
b: PBIO;
s: AnsiString;
{$IFDEF CIL}
sb: stringbuilder;
{$ENDIF}
begin
if not assigned(FSsl) then
begin
Result := '';
Exit;
end;
cert := SSLGetPeerCertificate(Fssl);
if not assigned(cert) then
begin
Result := '';
Exit;
end;
try {pf}
b := BioNew(BioSMem);
try
X509Print(b, cert);
x := bioctrlpending(b);
{$IFDEF CIL}
sb := StringBuilder.Create(x);
y := bioread(b, sb, x);
if y > 0 then
begin
sb.Length := y;
s := sb.ToString;
end;
{$ELSE}
setlength(s,x);
y := bioread(b,s,x);
if y > 0 then
setlength(s, y);
{$ENDIF}
Result := ReplaceString(s, LF, CRLF);
finally
BioFreeAll(b);
end;
{pf}
finally
X509Free(cert);
end;
{/pf}
end;
function TSSLOpenSSL.GetCipherName: string;
begin
if not assigned(FSsl) then
Result := ''
else
Result := SslCipherGetName(SslGetCurrentCipher(FSsl));
end;
function TSSLOpenSSL.GetCipherBits: integer;
var
x: integer;
begin
if not assigned(FSsl) then
Result := 0
else
Result := SSLCipherGetBits(SslGetCurrentCipher(FSsl), x);
end;
function TSSLOpenSSL.GetCipherAlgBits: integer;
begin
if not assigned(FSsl) then
Result := 0
else
SSLCipherGetBits(SslGetCurrentCipher(FSsl), Result);
end;
function TSSLOpenSSL.GetVerifyCert: integer;
begin
if not assigned(FSsl) then
Result := 1
else
Result := SslGetVerifyResult(FSsl);
end;
{==============================================================================}
initialization
if InitSSLInterface then
SSLImplementation := TSSLOpenSSL;
end.

2138
synapse/ssl_openssl_lib.pas Normal file
View File

File diff suppressed because it is too large Load Diff

697
synapse/ssl_sbb.pas Normal file
View File

@ -0,0 +1,697 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.003 |
|==============================================================================|
| Content: SSL support for SecureBlackBox |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Allen Drennan (adrennan@wiredred.com) |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SSL plugin for Eldos SecureBlackBox)
For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
of keys and certificates refer to SecureBlackBox documentation.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ssl_sbb;
interface
uses
SysUtils, Classes, Windows, blcksock, synsock, synautil, synacode,
SBClient, SBServer, SBX509, SBWinCertStorage, SBCustomCertStorage,
SBUtils, SBConstants, SBSessionPool;
const
DEFAULT_RECV_BUFFER=32768;
type
{:@abstract(class implementing SecureBlackbox SSL plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLSBB=class(TCustomSSL)
protected
FServer: Boolean;
FElSecureClient:TElSecureClient;
FElSecureServer:TElSecureServer;
FElCertStorage:TElMemoryCertStorage;
FElX509Certificate:TElX509Certificate;
FElX509CACertificate:TElX509Certificate;
FCipherSuites:TBits;
private
FRecvBuffer:String;
FRecvBuffers:String;
FRecvBuffersLock:TRTLCriticalSection;
FRecvDecodedBuffers:String;
function GetCipherSuite:Integer;
procedure Reset;
function Prepare(Server:Boolean):Boolean;
procedure OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean);
procedure OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt);
procedure OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt);
procedure OnData(Sender:TObject;Buffer:Pointer;Size:LongInt);
public
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited and @link(ssl_sbb) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_sbb) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
published
property ElSecureClient:TElSecureClient read FElSecureClient write FElSecureClient;
property ElSecureServer:TElSecureServer read FElSecureServer write FElSecureServer;
property CipherSuites:TBits read FCipherSuites write FCipherSuites;
property CipherSuite:Integer read GetCipherSuite;
end;
implementation
var
FAcceptThread:THandle=0;
// on error
procedure TSSLSBB.OnError(Sender:TObject; ErrorCode:Integer; Fatal:Boolean; Remote:Boolean);
begin
FLastErrorDesc:='';
FLastError:=ErrorCode;
end;
// on send
procedure TSSLSBB.OnSend(Sender:TObject;Buffer:Pointer;Size:LongInt);
var
lResult:Integer;
begin
if FSocket.Socket=INVALID_SOCKET then
Exit;
lResult:=Send(FSocket.Socket,Buffer,Size,0);
if lResult=SOCKET_ERROR then
begin
FLastErrorDesc:='';
FLastError:=WSAGetLastError;
end;
end;
// on receive
procedure TSSLSBB.OnReceive(Sender:TObject;Buffer:Pointer;MaxSize:LongInt;var Written:LongInt);
begin
if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
try
if Length(FRecvBuffers)<=MaxSize then
begin
Written:=Length(FRecvBuffers);
Move(FRecvBuffers[1],Buffer^,Written);
FRecvBuffers:='';
end
else
begin
Written:=MaxSize;
Move(FRecvBuffers[1],Buffer^,Written);
Delete(FRecvBuffers,1,Written);
end;
finally
if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
end;
end;
// on data
procedure TSSLSBB.OnData(Sender:TObject;Buffer:Pointer;Size:LongInt);
var
lString:String;
begin
SetLength(lString,Size);
Move(Buffer^,lString[1],Size);
FRecvDecodedBuffers:=FRecvDecodedBuffers+lString;
end;
{ inherited }
constructor TSSLSBB.Create(const Value: TTCPBlockSocket);
var
loop1:Integer;
begin
inherited Create(Value);
FServer:=FALSE;
FElSecureClient:=NIL;
FElSecureServer:=NIL;
FElCertStorage:=NIL;
FElX509Certificate:=NIL;
FElX509CACertificate:=NIL;
SetLength(FRecvBuffer,DEFAULT_RECV_BUFFER);
FRecvBuffers:='';
InitializeCriticalSection(FRecvBuffersLock);
FRecvDecodedBuffers:='';
FCipherSuites:=TBits.Create;
if FCipherSuites<>NIL then
begin
FCipherSuites.Size:=SB_SUITE_LAST+1;
for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do
FCipherSuites[loop1]:=TRUE;
end;
end;
destructor TSSLSBB.Destroy;
begin
Reset;
inherited Destroy;
if FCipherSuites<>NIL then
FreeAndNIL(FCipherSuites);
DeleteCriticalSection(FRecvBuffersLock);
end;
function TSSLSBB.LibVersion: String;
begin
Result:='SecureBlackBox';
end;
function TSSLSBB.LibName: String;
begin
Result:='ssl_sbb';
end;
function FileToString(lFile:String):String;
var
lStream:TMemoryStream;
begin
Result:='';
lStream:=TMemoryStream.Create;
if lStream<>NIL then
begin
lStream.LoadFromFile(lFile);
if lStream.Size>0 then
begin
lStream.Position:=0;
SetLength(Result,lStream.Size);
Move(lStream.Memory^,Result[1],lStream.Size);
end;
lStream.Free;
end;
end;
function TSSLSBB.GetCipherSuite:Integer;
begin
if FServer then
Result:=FElSecureServer.CipherSuite
else
Result:=FElSecureClient.CipherSuite;
end;
procedure TSSLSBB.Reset;
begin
if FElSecureServer<>NIL then
FreeAndNIL(FElSecureServer);
if FElSecureClient<>NIL then
FreeAndNIL(FElSecureClient);
if FElX509Certificate<>NIL then
FreeAndNIL(FElX509Certificate);
if FElX509CACertificate<>NIL then
FreeAndNIL(FElX509CACertificate);
if FElCertStorage<>NIL then
FreeAndNIL(FElCertStorage);
FSSLEnabled:=FALSE;
end;
function TSSLSBB.Prepare(Server:Boolean): Boolean;
var
loop1:Integer;
lStream:TMemoryStream;
lCertificate,lPrivateKey,lCertCA:String;
begin
Result:=FALSE;
FServer:=Server;
// reset, if necessary
Reset;
// init, certificate
if FCertificateFile<>'' then
lCertificate:=FileToString(FCertificateFile)
else
lCertificate:=FCertificate;
if FPrivateKeyFile<>'' then
lPrivateKey:=FileToString(FPrivateKeyFile)
else
lPrivateKey:=FPrivateKey;
if FCertCAFile<>'' then
lCertCA:=FileToString(FCertCAFile)
else
lCertCA:=FCertCA;
if (lCertificate<>'') and (lPrivateKey<>'') then
begin
FElCertStorage:=TElMemoryCertStorage.Create(NIL);
if FElCertStorage<>NIL then
FElCertStorage.Clear;
// apply ca certificate
if lCertCA<>'' then
begin
FElX509CACertificate:=TElX509Certificate.Create(NIL);
if FElX509CACertificate<>NIL then
begin
with FElX509CACertificate do
begin
lStream:=TMemoryStream.Create;
try
WriteStrToStream(lStream,lCertCA);
lStream.Seek(0,soFromBeginning);
LoadFromStream(lStream);
finally
lStream.Free;
end;
end;
if FElCertStorage<>NIL then
FElCertStorage.Add(FElX509CACertificate);
end;
end;
// apply certificate
FElX509Certificate:=TElX509Certificate.Create(NIL);
if FElX509Certificate<>NIL then
begin
with FElX509Certificate do
begin
lStream:=TMemoryStream.Create;
try
WriteStrToStream(lStream,lCertificate);
lStream.Seek(0,soFromBeginning);
LoadFromStream(lStream);
finally
lStream.Free;
end;
lStream:=TMemoryStream.Create;
try
WriteStrToStream(lStream,lPrivateKey);
lStream.Seek(0,soFromBeginning);
LoadKeyFromStream(lStream);
finally
lStream.Free;
end;
if FElCertStorage<>NIL then
FElCertStorage.Add(FElX509Certificate);
end;
end;
end;
// init, as server
if FServer then
begin
FElSecureServer:=TElSecureServer.Create(NIL);
if FElSecureServer<>NIL then
begin
// init, ciphers
for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do
FElSecureServer.CipherSuites[loop1]:=FCipherSuites[loop1];
FElSecureServer.Versions:=[sbSSL2,sbSSL3,sbTLS1];
FElSecureServer.ClientAuthentication:=FALSE;
FElSecureServer.OnError:=OnError;
FElSecureServer.OnSend:=OnSend;
FElSecureServer.OnReceive:=OnReceive;
FElSecureServer.OnData:=OnData;
FElSecureServer.CertStorage:=FElCertStorage;
Result:=TRUE;
end;
end
else
// init, as client
begin
FElSecureClient:=TElSecureClient.Create(NIL);
if FElSecureClient<>NIL then
begin
// init, ciphers
for loop1:=SB_SUITE_FIRST to SB_SUITE_LAST do
FElSecureClient.CipherSuites[loop1]:=FCipherSuites[loop1];
FElSecureClient.Versions:=[sbSSL3,sbTLS1];
FElSecureClient.OnError:=OnError;
FElSecureClient.OnSend:=OnSend;
FElSecureClient.OnReceive:=OnReceive;
FElSecureClient.OnData:=OnData;
FElSecureClient.CertStorage:=FElCertStorage;
Result:=TRUE;
end;
end;
end;
function TSSLSBB.Connect:Boolean;
var
lResult:Integer;
begin
Result:=FALSE;
if FSocket.Socket=INVALID_SOCKET then
Exit;
if Prepare(FALSE) then
begin
FElSecureClient.Open;
// reset
FRecvBuffers:='';
FRecvDecodedBuffers:='';
// wait for open or error
while (not FElSecureClient.Active) and
(FLastError=0) do
begin
// data available?
if FRecvBuffers<>'' then
FElSecureClient.DataAvailable
else
begin
// socket recv
lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0);
if lResult=SOCKET_ERROR then
begin
FLastErrorDesc:='';
FLastError:=WSAGetLastError;
end
else
begin
if lResult>0 then
FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult)
else
Break;
end;
end;
end;
if FLastError<>0 then
Exit;
FSSLEnabled:=FElSecureClient.Active;
Result:=FSSLEnabled;
end;
end;
function TSSLSBB.Accept:Boolean;
var
lResult:Integer;
begin
Result:=FALSE;
if FSocket.Socket=INVALID_SOCKET then
Exit;
if Prepare(TRUE) then
begin
FAcceptThread:=GetCurrentThreadId;
FElSecureServer.Open;
// reset
FRecvBuffers:='';
FRecvDecodedBuffers:='';
// wait for open or error
while (not FElSecureServer.Active) and
(FLastError=0) do
begin
// data available?
if FRecvBuffers<>'' then
FElSecureServer.DataAvailable
else
begin
// socket recv
lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0);
if lResult=SOCKET_ERROR then
begin
FLastErrorDesc:='';
FLastError:=WSAGetLastError;
end
else
begin
if lResult>0 then
FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult)
else
Break;
end;
end;
end;
if FLastError<>0 then
Exit;
FSSLEnabled:=FElSecureServer.Active;
Result:=FSSLEnabled;
end;
end;
function TSSLSBB.Shutdown:Boolean;
begin
Result:=BiShutdown;
end;
function TSSLSBB.BiShutdown: boolean;
begin
Reset;
Result:=TRUE;
end;
function TSSLSBB.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
begin
if FServer then
FElSecureServer.SendData(Buffer,Len)
else
FElSecureClient.SendData(Buffer,Len);
Result:=Len;
end;
function TSSLSBB.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
begin
Result:=0;
try
// recv waiting, if necessary
if FRecvDecodedBuffers='' then
WaitingData;
// received
if Length(FRecvDecodedBuffers)<Len then
begin
Result:=Length(FRecvDecodedBuffers);
Move(FRecvDecodedBuffers[1],Buffer^,Result);
FRecvDecodedBuffers:='';
end
else
begin
Result:=Len;
Move(FRecvDecodedBuffers[1],Buffer^,Result);
Delete(FRecvDecodedBuffers,1,Result);
end;
except
// ignore
end;
end;
function TSSLSBB.WaitingData: Integer;
var
lResult:Integer;
lRecvBuffers:Boolean;
begin
Result:=0;
if FSocket.Socket=INVALID_SOCKET then
Exit;
// data available?
if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
try
lRecvBuffers:=FRecvBuffers<>'';
finally
if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
end;
if lRecvBuffers then
begin
if FServer then
FElSecureServer.DataAvailable
else
FElSecureClient.DataAvailable;
end
else
begin
// socket recv
lResult:=Recv(FSocket.Socket,@FRecvBuffer[1],Length(FRecvBuffer),0);
if lResult=SOCKET_ERROR then
begin
FLastErrorDesc:='';
FLastError:=WSAGetLastError;
end
else
begin
if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
try
FRecvBuffers:=FRecvBuffers+Copy(FRecvBuffer,1,lResult);
finally
if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
end;
// data available?
if GetCurrentThreadId<>FAcceptThread then EnterCriticalSection(FRecvBuffersLock);
try
lRecvBuffers:=FRecvBuffers<>'';
finally
if GetCurrentThreadId<>FAcceptThread then LeaveCriticalSection(FRecvBuffersLock);
end;
if lRecvBuffers then
begin
if FServer then
FElSecureServer.DataAvailable
else
FElSecureClient.DataAvailable;
end;
end;
end;
// decoded buffers result
Result:=Length(FRecvDecodedBuffers);
end;
function TSSLSBB.GetSSLVersion: string;
begin
Result:='SSLv3 or TLSv1';
end;
function TSSLSBB.GetPeerSubject: string;
begin
Result := '';
// if FServer then
// must return subject of the client certificate
// else
// must return subject of the server certificate
end;
function TSSLSBB.GetPeerName: string;
begin
Result := '';
// if FServer then
// must return commonname of the client certificate
// else
// must return commonname of the server certificate
end;
function TSSLSBB.GetPeerIssuer: string;
begin
Result := '';
// if FServer then
// must return issuer of the client certificate
// else
// must return issuer of the server certificate
end;
function TSSLSBB.GetPeerFingerprint: string;
begin
Result := '';
// if FServer then
// must return a unique hash string of the client certificate
// else
// must return a unique hash string of the server certificate
end;
function TSSLSBB.GetCertInfo: string;
begin
Result := '';
// if FServer then
// must return a text representation of the ASN of the client certificate
// else
// must return a text representation of the ASN of the server certificate
end;
{==============================================================================}
initialization
SSLImplementation := TSSLSBB;
finalization
end.

539
synapse/ssl_streamsec.pas Normal file
View File

@ -0,0 +1,539 @@
{==============================================================================|
| Project : Ararat Synapse | 001.000.006 |
|==============================================================================|
| Content: SSL support by StreamSecII |
|==============================================================================|
| Copyright (c)1999-2005, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2005. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Henrick Hellström <henrick@streamsec.se> |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(SSL plugin for StreamSecII or OpenStreamSecII)
StreamSecII is native pascal library, you not need any external libraries!
You can tune lot of StreamSecII properties by using your GlobalServer. If you not
using your GlobalServer, then this plugin create own TSimpleTLSInternalServer
instance for each TCP connection. Formore information about GlobalServer usage
refer StreamSecII documentation.
If you are not using key and certificate by GlobalServer, then you can use
properties of this plugin instead, but this have limited features and
@link(TCustomSSL.KeyPassword) not working properly yet!
For handling keys and certificates you can use this properties:
@link(TCustomSSL.CertCAFile), @link(TCustomSSL.CertCA),
@link(TCustomSSL.TrustCertificateFile), @link(TCustomSSL.TrustCertificate),
@link(TCustomSSL.PrivateKeyFile), @link(TCustomSSL.PrivateKey),
@link(TCustomSSL.CertificateFile), @link(TCustomSSL.Certificate),
@link(TCustomSSL.PFXFile). For usage of this properties and for possible formats
of keys and certificates refer to StreamSecII documentation.
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
unit ssl_streamsec;
interface
uses
SysUtils, Classes,
blcksock, synsock, synautil, synacode,
TlsInternalServer, TlsSynaSock, TlsConst, StreamSecII, Asn1, X509Base,
SecUtils;
type
{:@exclude}
TMyTLSSynSockSlave = class(TTLSSynSockSlave)
protected
procedure SetMyTLSServer(const Value: TCustomTLSInternalServer);
function GetMyTLSServer: TCustomTLSInternalServer;
published
property MyTLSServer: TCustomTLSInternalServer read GetMyTLSServer write SetMyTLSServer;
end;
{:@abstract(class implementing StreamSecII SSL plugin.)
Instance of this class will be created for each @link(TTCPBlockSocket).
You not need to create instance of this class, all is done by Synapse itself!}
TSSLStreamSec = class(TCustomSSL)
protected
FSlave: TMyTLSSynSockSlave;
FIsServer: Boolean;
FTLSServer: TCustomTLSInternalServer;
FServerCreated: Boolean;
function SSLCheck: Boolean;
function Init(server:Boolean): Boolean;
function DeInit: Boolean;
function Prepare(server:Boolean): Boolean;
procedure NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
function X500StrToStr(const Prefix: string; const Value: TX500String): string;
function X501NameToStr(const Value: TX501Name): string;
function GetCert: PASN1Struct;
public
constructor Create(const Value: TTCPBlockSocket); override;
destructor Destroy; override;
{:See @inherited}
function LibVersion: String; override;
{:See @inherited}
function LibName: String; override;
{:See @inherited and @link(ssl_streamsec) for more details.}
function Connect: boolean; override;
{:See @inherited and @link(ssl_streamsec) for more details.}
function Accept: boolean; override;
{:See @inherited}
function Shutdown: boolean; override;
{:See @inherited}
function BiShutdown: boolean; override;
{:See @inherited}
function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override;
{:See @inherited}
function WaitingData: Integer; override;
{:See @inherited}
function GetSSLVersion: string; override;
{:See @inherited}
function GetPeerSubject: string; override;
{:See @inherited}
function GetPeerIssuer: string; override;
{:See @inherited}
function GetPeerName: string; override;
{:See @inherited}
function GetPeerFingerprint: string; override;
{:See @inherited}
function GetCertInfo: string; override;
published
{:TLS server for tuning of StreamSecII.}
property TLSServer: TCustomTLSInternalServer read FTLSServer write FTLSServer;
end;
implementation
{==============================================================================}
procedure TMyTLSSynSockSlave.SetMyTLSServer(const Value: TCustomTLSInternalServer);
begin
TLSServer := Value;
end;
function TMyTLSSynSockSlave.GetMyTLSServer: TCustomTLSInternalServer;
begin
Result := TLSServer;
end;
{==============================================================================}
constructor TSSLStreamSec.Create(const Value: TTCPBlockSocket);
begin
inherited Create(Value);
FSlave := nil;
FIsServer := False;
FTLSServer := nil;
end;
destructor TSSLStreamSec.Destroy;
begin
DeInit;
inherited Destroy;
end;
function TSSLStreamSec.LibVersion: String;
begin
Result := 'StreamSecII';
end;
function TSSLStreamSec.LibName: String;
begin
Result := 'ssl_streamsec';
end;
function TSSLStreamSec.SSLCheck: Boolean;
begin
Result := true;
FLastErrorDesc := '';
if not Assigned(FSlave) then
Exit;
FLastError := FSlave.ErrorCode;
if FLastError <> 0 then
begin
FLastErrorDesc := TlsConst.AlertMsg(FLastError);
end;
end;
procedure TSSLStreamSec.NotTrustEvent(Sender: TObject; Cert: TASN1Struct; var ExplicitTrust: Boolean);
begin
ExplicitTrust := true;
end;
function TSSLStreamSec.Init(server:Boolean): Boolean;
var
st: TMemoryStream;
pass: ISecretKey;
ws: WideString;
begin
Result := False;
ws := FKeyPassword;
pass := TSecretKey.CreateBmpStr(PWideChar(ws), length(ws));
try
FIsServer := Server;
FSlave := TMyTLSSynSockSlave.CreateSocket(FSocket.Socket);
if Assigned(FTLSServer) then
FSlave.MyTLSServer := FTLSServer
else
if Assigned(TLSInternalServer.GlobalServer) then
FSlave.MyTLSServer := TLSInternalServer.GlobalServer
else begin
FSlave.MyTLSServer := TSimpleTLSInternalServer.Create(nil);
FServerCreated := True;
end;
if server then
FSlave.MyTLSServer.ClientOrServer := cosServerSide
else
FSlave.MyTLSServer.ClientOrServer := cosClientSide;
if not FVerifyCert then
begin
FSlave.MyTLSServer.OnCertNotTrusted := NotTrustEvent;
end;
FSlave.MyTLSServer.Options.VerifyServerName := [];
FSlave.MyTLSServer.Options.Export40Bit := prAllowed;
FSlave.MyTLSServer.Options.Export56Bit := prAllowed;
FSlave.MyTLSServer.Options.RequestClientCertificate := False;
FSlave.MyTLSServer.Options.RequireClientCertificate := False;
if server and FVerifyCert then
begin
FSlave.MyTLSServer.Options.RequestClientCertificate := True;
FSlave.MyTLSServer.Options.RequireClientCertificate := True;
end;
if FCertCAFile <> '' then
FSlave.MyTLSServer.LoadRootCertsFromFile(CertCAFile);
if FCertCA <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FCertCA);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadRootCertsFromStream(st);
finally
st.free;
end;
end;
if FTrustCertificateFile <> '' then
FSlave.MyTLSServer.LoadTrustedCertsFromFile(FTrustCertificateFile);
if FTrustCertificate <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FTrustCertificate);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadTrustedCertsFromStream(st);
finally
st.free;
end;
end;
if FPrivateKeyFile <> '' then
FSlave.MyTLSServer.LoadPrivateKeyRingFromFile(FPrivateKeyFile, pass);
// FSlave.MyTLSServer.PrivateKeyRing.LoadPrivateKeyFromFile(FPrivateKeyFile, pass);
if FPrivateKey <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FPrivateKey);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadPrivateKeyRingFromStream(st, pass);
finally
st.free;
end;
end;
if FCertificateFile <> '' then
FSlave.MyTLSServer.LoadMyCertsFromFile(FCertificateFile);
if FCertificate <> '' then
begin
st := TMemoryStream.Create;
try
WriteStrToStream(st, FCertificate);
st.Seek(0, soFromBeginning);
FSlave.MyTLSServer.LoadMyCertsFromStream(st);
finally
st.free;
end;
end;
if FPFXfile <> '' then
FSlave.MyTLSServer.ImportFromPFX(FPFXfile, pass);
if server and FServerCreated then
begin
FSlave.MyTLSServer.Options.BulkCipherAES128 := prPrefer;
FSlave.MyTLSServer.Options.BulkCipherAES256 := prAllowed;
FSlave.MyTLSServer.Options.EphemeralECDHKeySize := ecs256;
FSlave.MyTLSServer.Options.SignatureRSA := prPrefer;
FSlave.MyTLSServer.Options.KeyAgreementRSA := prAllowed;
FSlave.MyTLSServer.Options.KeyAgreementECDHE := prAllowed;
FSlave.MyTLSServer.Options.KeyAgreementDHE := prPrefer;
FSlave.MyTLSServer.TLSSetupServer;
end;
Result := true;
finally
pass := nil;
end;
end;
function TSSLStreamSec.DeInit: Boolean;
var
obj: TObject;
begin
Result := True;
if assigned(FSlave) then
begin
FSlave.Close;
if FServerCreated then
obj := FSlave.TLSServer
else
obj := nil;
FSlave.Free;
obj.Free;
FSlave := nil;
end;
FSSLEnabled := false;
end;
function TSSLStreamSec.Prepare(server:Boolean): Boolean;
begin
Result := false;
DeInit;
if Init(server) then
Result := true
else
DeInit;
end;
function TSSLStreamSec.Connect: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(false) then
begin
FSlave.Open;
SSLCheck;
if FLastError <> 0 then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLStreamSec.Accept: boolean;
begin
Result := False;
if FSocket.Socket = INVALID_SOCKET then
Exit;
if Prepare(true) then
begin
FSlave.DoConnect;
SSLCheck;
if FLastError <> 0 then
Exit;
FSSLEnabled := True;
Result := True;
end;
end;
function TSSLStreamSec.Shutdown: boolean;
begin
Result := BiShutdown;
end;
function TSSLStreamSec.BiShutdown: boolean;
begin
DeInit;
Result := True;
end;
function TSSLStreamSec.SendBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
l := len;
FSlave.SendBuf(Buffer^, l, true);
Result := l;
SSLCheck;
end;
function TSSLStreamSec.RecvBuffer(Buffer: TMemory; Len: Integer): Integer;
var
l: integer;
begin
l := Len;
Result := FSlave.ReceiveBuf(Buffer^, l);
SSLCheck;
end;
function TSSLStreamSec.WaitingData: Integer;
begin
Result := 0;
while FSlave.Connected do begin
Result := FSlave.ReceiveLength;
if Result > 0 then
Break;
Sleep(1);
end;
end;
function TSSLStreamSec.GetSSLVersion: string;
begin
Result := 'SSLv3 or TLSv1';
end;
function TSSLStreamSec.GetCert: PASN1Struct;
begin
if FIsServer then
Result := FSlave.GetClientCert
else
Result := FSlave.GetServerCert;
end;
function TSSLStreamSec.GetPeerSubject: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractSubject(Cert^,XName, false);
Result := X501NameToStr(XName);
end;
end;
function TSSLStreamSec.GetPeerName: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractSubject(Cert^,XName, false);
Result := XName.commonName.Str;
end;
end;
function TSSLStreamSec.GetPeerIssuer: string;
var
XName: TX501Name;
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
ExtractIssuer(Cert^, XName, false);
Result := X501NameToStr(XName);
end;
end;
function TSSLStreamSec.GetPeerFingerprint: string;
var
Cert: PASN1Struct;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
Result := MD5(Cert.ContentAsOctetString);
end;
function TSSLStreamSec.GetCertInfo: string;
var
Cert: PASN1Struct;
l: Tstringlist;
begin
Result := '';
Cert := GetCert;
if Assigned(cert) then
begin
l := TStringList.Create;
try
Asn1.RenderAsText(cert^, l, true, true, true, 2);
Result := l.Text;
finally
l.free;
end;
end;
end;
function TSSLStreamSec.X500StrToStr(const Prefix: string;
const Value: TX500String): string;
begin
if Value.Str = '' then
Result := ''
else
Result := '/' + Prefix + '=' + Value.Str;
end;
function TSSLStreamSec.X501NameToStr(const Value: TX501Name): string;
begin
Result := X500StrToStr('CN',Value.commonName) +
X500StrToStr('C',Value.countryName) +
X500StrToStr('L',Value.localityName) +
X500StrToStr('ST',Value.stateOrProvinceName) +
X500StrToStr('O',Value.organizationName) +
X500StrToStr('OU',Value.organizationalUnitName) +
X500StrToStr('T',Value.title) +
X500StrToStr('N',Value.name) +
X500StrToStr('G',Value.givenName) +
X500StrToStr('I',Value.initials) +
X500StrToStr('SN',Value.surname) +
X500StrToStr('GQ',Value.generationQualifier) +
X500StrToStr('DNQ',Value.dnQualifier) +
X500StrToStr('E',Value.emailAddress);
end;
{==============================================================================}
initialization
SSLImplementation := TSSLStreamSec;
finalization
end.

1314
synapse/sslinux.inc Normal file
View File

File diff suppressed because it is too large Load Diff

1615
synapse/sswin32.inc Normal file
View File

File diff suppressed because it is too large Load Diff

2035
synapse/synachar.pas Normal file
View File

File diff suppressed because it is too large Load Diff

1461
synapse/synacode.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2412
synapse/synacrypt.pas Normal file
View File

File diff suppressed because it is too large Load Diff

156
synapse/synadbg.pas Normal file
View File

@ -0,0 +1,156 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.002 |
|==============================================================================|
| Content: Socket debug tools |
|==============================================================================|
| Copyright (c)2008-2011, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2008-2011. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Socket debug tools)
Routines for help with debugging of events on the Sockets.
}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit synadbg;
interface
uses
blcksock, synsock, synautil, classes, sysutils, synafpc;
type
TSynaDebug = class(TObject)
class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
end;
procedure AppendToLog(const value: Ansistring);
var
LogFile: string;
implementation
procedure AppendToLog(const value: Ansistring);
var
st: TFileStream;
s: string;
h, m, ss, ms: word;
dt: Tdatetime;
begin
if fileexists(LogFile) then
st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite)
else
st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite);
try
st.Position := st.Size;
dt := now;
decodetime(dt, h, m, ss, ms);
s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value;
WriteStrToStream(st, s);
finally
st.free;
end;
end;
class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string);
var
s: string;
begin
case Reason of
HR_ResolvingBegin:
s := 'HR_ResolvingBegin';
HR_ResolvingEnd:
s := 'HR_ResolvingEnd';
HR_SocketCreate:
s := 'HR_SocketCreate';
HR_SocketClose:
s := 'HR_SocketClose';
HR_Bind:
s := 'HR_Bind';
HR_Connect:
s := 'HR_Connect';
HR_CanRead:
s := 'HR_CanRead';
HR_CanWrite:
s := 'HR_CanWrite';
HR_Listen:
s := 'HR_Listen';
HR_Accept:
s := 'HR_Accept';
HR_ReadCount:
s := 'HR_ReadCount';
HR_WriteCount:
s := 'HR_WriteCount';
HR_Wait:
s := 'HR_Wait';
HR_Error:
s := 'HR_Error';
else
s := '-unknown-';
end;
s := inttohex(PtrInt(Sender), 8) + s + ': ' + value + CRLF;
AppendToLog(s);
end;
class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer);
var
s, d: Ansistring;
begin
setlength(s, len);
move(Buffer^, pointer(s)^, len);
if writing then
d := '-> '
else
d := '<- ';
s :=inttohex(PtrInt(Sender), 8) + d + s + CRLF;
AppendToLog(s);
end;
initialization
begin
Logfile := changefileext(paramstr(0), '.slog');
end;
end.

141
synapse/synafpc.pas Normal file
View File

@ -0,0 +1,141 @@
{==============================================================================|
| Project : Ararat Synapse | 001.002.000 |
|==============================================================================|
| Content: Utils for FreePascal compatibility |
|==============================================================================|
| Copyright (c)1999-2011, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2003-2011. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
unit synafpc;
interface
uses
{$IFDEF FPC}
dynlibs, sysutils;
{$ELSE}
{$IFDEF MSWINDOWS}
Windows;
{$ELSE}
SysUtils;
{$ENDIF}
{$ENDIF}
{$IFDEF FPC}
type
TLibHandle = dynlibs.TLibHandle;
function LoadLibrary(ModuleName: PChar): TLibHandle;
function FreeLibrary(Module: TLibHandle): LongBool;
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
{$ELSE}
type
{$IFDEF CIL}
TLibHandle = Integer;
PtrInt = Integer;
{$ELSE}
TLibHandle = HModule;
{$IFNDEF WIN64}
PtrInt = Integer;
{$ENDIF}
{$ENDIF}
{$IFDEF VER100}
LongWord = DWord;
{$ENDIF}
{$ENDIF}
procedure Sleep(milliseconds: Cardinal);
implementation
{==============================================================================}
{$IFDEF FPC}
function LoadLibrary(ModuleName: PChar): TLibHandle;
begin
Result := dynlibs.LoadLibrary(Modulename);
end;
function FreeLibrary(Module: TLibHandle): LongBool;
begin
Result := dynlibs.UnloadLibrary(Module);
end;
function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer;
begin
Result := dynlibs.GetProcedureAddress(Module, Proc);
end;
function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer;
begin
Result := 0;
end;
{$ELSE}
{$ENDIF}
procedure Sleep(milliseconds: Cardinal);
begin
{$IFDEF MSWINDOWS}
{$IFDEF FPC}
sysutils.sleep(milliseconds);
{$ELSE}
windows.sleep(milliseconds);
{$ENDIF}
{$ELSE}
sysutils.sleep(milliseconds);
{$ENDIF}
end;
end.

363
synapse/synaicnv.pas Normal file
View File

@ -0,0 +1,363 @@
{==============================================================================|
| Project : Ararat Synapse | 001.001.001 |
|==============================================================================|
| Content: ICONV support for Win32, Linux and .NET |
|==============================================================================|
| Copyright (c)2004-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2004-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{:@abstract(LibIconv support)
This unit is Pascal interface to LibIconv library for charset translations.
LibIconv is loaded dynamicly on-demand. If this library is not found in system,
requested LibIconv function just return errorcode.
}
unit synaicnv;
interface
uses
{$IFDEF CIL}
System.Runtime.InteropServices,
System.Text,
{$ENDIF}
synafpc,
{$IFNDEF MSWINDOWS}
{$IFNDEF FPC}
Libc,
{$ENDIF}
SysUtils;
{$ELSE}
Windows;
{$ENDIF}
const
{$IFNDEF MSWINDOWS}
DLLIconvName = 'libiconv.so';
{$ELSE}
DLLIconvName = 'iconv.dll';
{$ENDIF}
type
size_t = Cardinal;
{$IFDEF CIL}
iconv_t = IntPtr;
{$ELSE}
iconv_t = Pointer;
{$ENDIF}
argptr = iconv_t;
var
iconvLibHandle: TLibHandle = 0;
function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t;
function SynaIconvOpenTranslit(const tocode, fromcode: Ansistring): iconv_t;
function SynaIconvOpenIgnore(const tocode, fromcode: Ansistring): iconv_t;
function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
function SynaIconvClose(var cd: iconv_t): integer;
function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer;
function IsIconvloaded: Boolean;
function InitIconvInterface: Boolean;
function DestroyIconvInterface: Boolean;
const
ICONV_TRIVIALP = 0; // int *argument
ICONV_GET_TRANSLITERATE = 1; // int *argument
ICONV_SET_TRANSLITERATE = 2; // const int *argument
ICONV_GET_DISCARD_ILSEQ = 3; // int *argument
ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument
implementation
uses SyncObjs;
{$IFDEF CIL}
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconv_open')]
function _iconv_open(tocode: string; fromcode: string): iconv_t; external;
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconv')]
function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t;
var outbuf: IntPtr; var outbytesleft: size_t): size_t; external;
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconv_close')]
function _iconv_close(cd: iconv_t): integer; external;
[DllImport(DLLIconvName, CharSet = CharSet.Ansi,
SetLastError = False, CallingConvention= CallingConvention.cdecl,
EntryPoint = 'libiconvctl')]
function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external;
{$ELSE}
type
Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl;
Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t;
var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl;
Ticonv_close = function(cd: iconv_t): integer; cdecl;
Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl;
var
_iconv_open: Ticonv_open = nil;
_iconv: Ticonv = nil;
_iconv_close: Ticonv_close = nil;
_iconvctl: Ticonvctl = nil;
{$ENDIF}
var
IconvCS: TCriticalSection;
Iconvloaded: boolean = false;
function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t;
begin
{$IFDEF CIL}
try
Result := _iconv_open(tocode, fromcode);
except
on Exception do
Result := iconv_t(-1);
end;
{$ELSE}
if InitIconvInterface and Assigned(_iconv_open) then
Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode))
else
Result := iconv_t(-1);
{$ENDIF}
end;
function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t;
begin
Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode);
end;
function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t;
begin
Result := SynaIconvOpen(tocode + '//IGNORE', fromcode);
end;
function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer;
var
{$IFDEF CIL}
ib, ob: IntPtr;
ibsave, obsave: IntPtr;
l: integer;
{$ELSE}
ib, ob: Pointer;
{$ENDIF}
ix, ox: size_t;
begin
{$IFDEF CIL}
l := Length(inbuf) * 4;
ibsave := IntPtr.Zero;
obsave := IntPtr.Zero;
try
ibsave := Marshal.StringToHGlobalAnsi(inbuf);
obsave := Marshal.AllocHGlobal(l);
ib := ibsave;
ob := obsave;
ix := Length(inbuf);
ox := l;
_iconv(cd, ib, ix, ob, ox);
Outbuf := Marshal.PtrToStringAnsi(obsave, l);
setlength(Outbuf, l - ox);
Result := Length(inbuf) - ix;
finally
Marshal.FreeCoTaskMem(ibsave);
Marshal.FreeHGlobal(obsave);
end;
{$ELSE}
if InitIconvInterface and Assigned(_iconv) then
begin
setlength(Outbuf, Length(inbuf) * 4);
ib := Pointer(inbuf);
ob := Pointer(Outbuf);
ix := Length(inbuf);
ox := Length(Outbuf);
_iconv(cd, ib, ix, ob, ox);
setlength(Outbuf, cardinal(Length(Outbuf)) - ox);
Result := Cardinal(Length(inbuf)) - ix;
end
else
begin
Outbuf := '';
Result := 0;
end;
{$ENDIF}
end;
function SynaIconvClose(var cd: iconv_t): integer;
begin
if cd = iconv_t(-1) then
begin
Result := 0;
Exit;
end;
{$IFDEF CIL}
try;
Result := _iconv_close(cd)
except
on Exception do
Result := -1;
end;
cd := iconv_t(-1);
{$ELSE}
if InitIconvInterface and Assigned(_iconv_close) then
Result := _iconv_close(cd)
else
Result := -1;
cd := iconv_t(-1);
{$ENDIF}
end;
function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer;
begin
{$IFDEF CIL}
Result := _iconvctl(cd, request, argument)
{$ELSE}
if InitIconvInterface and Assigned(_iconvctl) then
Result := _iconvctl(cd, request, argument)
else
Result := 0;
{$ENDIF}
end;
function InitIconvInterface: Boolean;
begin
IconvCS.Enter;
try
if not IsIconvloaded then
begin
{$IFDEF CIL}
IconvLibHandle := 1;
{$ELSE}
IconvLibHandle := LoadLibrary(PChar(DLLIconvName));
{$ENDIF}
if (IconvLibHandle <> 0) then
begin
{$IFNDEF CIL}
_iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open')));
_iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv')));
_iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close')));
_iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl')));
{$ENDIF}
Result := True;
Iconvloaded := True;
end
else
begin
//load failed!
if IconvLibHandle <> 0 then
begin
{$IFNDEF CIL}
FreeLibrary(IconvLibHandle);
{$ENDIF}
IconvLibHandle := 0;
end;
Result := False;
end;
end
else
//loaded before...
Result := true;
finally
IconvCS.Leave;
end;
end;
function DestroyIconvInterface: Boolean;
begin
IconvCS.Enter;
try
Iconvloaded := false;
if IconvLibHandle <> 0 then
begin
{$IFNDEF CIL}
FreeLibrary(IconvLibHandle);
{$ENDIF}
IconvLibHandle := 0;
end;
{$IFNDEF CIL}
_iconv_open := nil;
_iconv := nil;
_iconv_close := nil;
_iconvctl := nil;
{$ENDIF}
finally
IconvCS.Leave;
end;
Result := True;
end;
function IsIconvloaded: Boolean;
begin
Result := IconvLoaded;
end;
initialization
begin
IconvCS:= TCriticalSection.Create;
end;
finalization
begin
{$IFNDEF CIL}
DestroyIconvInterface;
{$ENDIF}
IconvCS.Free;
end;
end.

422
synapse/synaip.pas Normal file
View File

@ -0,0 +1,422 @@
{==============================================================================|
| Project : Ararat Synapse | 001.002.001 |
|==============================================================================|
| Content: IP address support procedures and functions |
|==============================================================================|
| Copyright (c)2006-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 2006-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(IP adress support procedures and functions)}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$WARN SUSPICIOUS_TYPECAST OFF}
{$ENDIF}
unit synaip;
interface
uses
SysUtils, SynaUtil;
type
{:binary form of IPv6 adress (for string conversion routines)}
TIp6Bytes = array [0..15] of Byte;
{:binary form of IPv6 adress (for string conversion routines)}
TIp6Words = array [0..7] of Word;
{:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!}
function IsIP(const Value: string): Boolean;
{:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!}
function IsIP6(const Value: string): Boolean;
{:Returns a string with the "Host" ip address converted to binary form.}
function IPToID(Host: string): Ansistring;
{:Convert IPv6 address from their string form to binary byte array.}
function StrToIp6(value: string): TIp6Bytes;
{:Convert IPv6 address from binary byte array to string form.}
function Ip6ToStr(value: TIp6Bytes): string;
{:Convert IPv4 address from their string form to binary.}
function StrToIp(value: string): integer;
{:Convert IPv4 address from binary to string form.}
function IpToStr(value: integer): string;
{:Convert IPv4 address to reverse form.}
function ReverseIP(Value: AnsiString): AnsiString;
{:Convert IPv6 address to reverse form.}
function ReverseIP6(Value: AnsiString): AnsiString;
{:Expand short form of IPv6 address to long form.}
function ExpandIP6(Value: AnsiString): AnsiString;
implementation
{==============================================================================}
function IsIP(const Value: string): Boolean;
var
TempIP: string;
function ByteIsOk(const Value: string): Boolean;
var
x, n: integer;
begin
x := StrToIntDef(Value, -1);
Result := (x >= 0) and (x < 256);
// X may be in correct range, but value still may not be correct value!
// i.e. "$80"
if Result then
for n := 1 to length(Value) do
if not (AnsiChar(Value[n]) in ['0'..'9']) then
begin
Result := False;
Break;
end;
end;
begin
TempIP := Value;
Result := False;
if not ByteIsOk(Fetch(TempIP, '.')) then
Exit;
if not ByteIsOk(Fetch(TempIP, '.')) then
Exit;
if not ByteIsOk(Fetch(TempIP, '.')) then
Exit;
if ByteIsOk(TempIP) then
Result := True;
end;
{==============================================================================}
function IsIP6(const Value: string): Boolean;
var
TempIP: string;
s,t: string;
x: integer;
partcount: integer;
zerocount: integer;
First: Boolean;
begin
TempIP := Value;
Result := False;
if Value = '::' then
begin
Result := True;
Exit;
end;
partcount := 0;
zerocount := 0;
First := True;
while tempIP <> '' do
begin
s := fetch(TempIP, ':');
if not(First) and (s = '') then
Inc(zerocount);
First := False;
if zerocount > 1 then
break;
Inc(partCount);
if s = '' then
Continue;
if partCount > 8 then
break;
if tempIP = '' then
begin
t := SeparateRight(s, '%');
s := SeparateLeft(s, '%');
x := StrToIntDef('$' + t, -1);
if (x < 0) or (x > $ffff) then
break;
end;
x := StrToIntDef('$' + s, -1);
if (x < 0) or (x > $ffff) then
break;
if tempIP = '' then
if not((PartCount = 1) and (ZeroCount = 0)) then
Result := True;
end;
end;
{==============================================================================}
function IPToID(Host: string): Ansistring;
var
s: string;
i, x: Integer;
begin
Result := '';
for x := 0 to 3 do
begin
s := Fetch(Host, '.');
i := StrToIntDef(s, 0);
Result := Result + AnsiChar(i);
end;
end;
{==============================================================================}
function StrToIp(value: string): integer;
var
s: string;
i, x: Integer;
begin
Result := 0;
for x := 0 to 3 do
begin
s := Fetch(value, '.');
i := StrToIntDef(s, 0);
Result := (256 * Result) + i;
end;
end;
{==============================================================================}
function IpToStr(value: integer): string;
var
x1, x2: word;
y1, y2: byte;
begin
Result := '';
x1 := value shr 16;
x2 := value and $FFFF;
y1 := x1 div $100;
y2 := x1 mod $100;
Result := inttostr(y1) + '.' + inttostr(y2) + '.';
y1 := x2 div $100;
y2 := x2 mod $100;
Result := Result + inttostr(y1) + '.' + inttostr(y2);
end;
{==============================================================================}
function ExpandIP6(Value: AnsiString): AnsiString;
var
n: integer;
s: ansistring;
x: integer;
begin
Result := '';
if value = '' then
exit;
x := countofchar(value, ':');
if x > 7 then
exit;
if value[1] = ':' then
value := '0' + value;
if value[length(value)] = ':' then
value := value + '0';
x := 8 - x;
s := '';
for n := 1 to x do
s := s + ':0';
s := s + ':';
Result := replacestring(value, '::', s);
end;
{==============================================================================}
function StrToIp6(Value: string): TIp6Bytes;
var
IPv6: TIp6Words;
Index: Integer;
n: integer;
b1, b2: byte;
s: string;
x: integer;
begin
for n := 0 to 15 do
Result[n] := 0;
for n := 0 to 7 do
Ipv6[n] := 0;
Index := 0;
Value := ExpandIP6(value);
if value = '' then
exit;
while Value <> '' do
begin
if Index > 7 then
Exit;
s := fetch(value, ':');
if s = '@' then
break;
if s = '' then
begin
IPv6[Index] := 0;
end
else
begin
x := StrToIntDef('$' + s, -1);
if (x > 65535) or (x < 0) then
Exit;
IPv6[Index] := x;
end;
Inc(Index);
end;
for n := 0 to 7 do
begin
b1 := ipv6[n] div 256;
b2 := ipv6[n] mod 256;
Result[n * 2] := b1;
Result[(n * 2) + 1] := b2;
end;
end;
{==============================================================================}
//based on routine by the Free Pascal development team
function Ip6ToStr(value: TIp6Bytes): string;
var
i, x: byte;
zr1,zr2: set of byte;
zc1,zc2: byte;
have_skipped: boolean;
ip6w: TIp6words;
begin
zr1 := [];
zr2 := [];
zc1 := 0;
zc2 := 0;
for i := 0 to 7 do
begin
x := i * 2;
ip6w[i] := value[x] * 256 + value[x + 1];
if ip6w[i] = 0 then
begin
include(zr2, i);
inc(zc2);
end
else
begin
if zc1 < zc2 then
begin
zc1 := zc2;
zr1 := zr2;
zc2 := 0;
zr2 := [];
end;
end;
end;
if zc1 < zc2 then
begin
zr1 := zr2;
end;
SetLength(Result, 8*5-1);
SetLength(Result, 0);
have_skipped := false;
for i := 0 to 7 do
begin
if not(i in zr1) then
begin
if have_skipped then
begin
if Result = '' then
Result := '::'
else
Result := Result + ':';
have_skipped := false;
end;
Result := Result + IntToHex(Ip6w[i], 1) + ':';
end
else
begin
have_skipped := true;
end;
end;
if have_skipped then
if Result = '' then
Result := '::0'
else
Result := Result + ':';
if Result = '' then
Result := '::0';
if not (7 in zr1) then
SetLength(Result, Length(Result)-1);
Result := LowerCase(result);
end;
{==============================================================================}
function ReverseIP(Value: AnsiString): AnsiString;
var
x: Integer;
begin
Result := '';
repeat
x := LastDelimiter('.', Value);
Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x);
Delete(Value, x, Length(Value) - x + 1);
until x < 1;
if Length(Result) > 0 then
if Result[1] = '.' then
Delete(Result, 1, 1);
end;
{==============================================================================}
function ReverseIP6(Value: AnsiString): AnsiString;
var
ip6: TIp6bytes;
n: integer;
x, y: integer;
begin
ip6 := StrToIP6(Value);
x := ip6[15] div 16;
y := ip6[15] mod 16;
Result := IntToHex(y, 1) + '.' + IntToHex(x, 1);
for n := 14 downto 0 do
begin
x := ip6[n] div 16;
y := ip6[n] mod 16;
Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1);
end;
end;
{==============================================================================}
end.

406
synapse/synamisc.pas Normal file
View File

@ -0,0 +1,406 @@
{==============================================================================|
| Project : Ararat Synapse | 001.003.001 |
|==============================================================================|
| Content: misc. procedures and functions |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c) 2002-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Misc. network based utilities)}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
//Kylix does not known UNIX define
{$IFDEF LINUX}
{$IFNDEF UNIX}
{$DEFINE UNIX}
{$ENDIF}
{$ENDIF}
{$TYPEDADDRESS OFF}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit synamisc;
interface
{$IFDEF VER125}
{$DEFINE BCB}
{$ENDIF}
{$IFDEF BCB}
{$ObjExportAll On}
{$HPPEMIT '#pragma comment( lib , "wininet.lib" )'}
{$ENDIF}
uses
synautil, blcksock, SysUtils, Classes
{$IFDEF UNIX}
{$IFNDEF FPC}
, Libc
{$ENDIF}
{$ELSE}
, Windows
{$ENDIF}
;
Type
{:@abstract(This record contains information about proxy setting.)}
TProxySetting = record
Host: string;
Port: string;
Bypass: string;
end;
{:By this function you can turn-on computer on network, if this computer
supporting Wake-on-lan feature. You need MAC number (network card indentifier)
of computer for turn-on. You can also assign target IP addres. If you not
specify it, then is used broadcast for delivery magic wake-on packet. However
broadcasts workinh only on your local network. When you need to wake-up
computer on another network, you must specify any existing IP addres on same
network segment as targeting computer.}
procedure WakeOnLan(MAC, IP: string);
{:Autodetect current DNS servers used by system. If is defined more then one DNS
server, then result is comma-delimited.}
function GetDNS: string;
{:Autodetect InternetExplorer proxy setting for given protocol. This function
working only on windows!}
function GetIEProxy(protocol: string): TProxySetting;
{:Return all known IP addresses on local system. Addresses are divided by comma.}
function GetLocalIPs: string;
implementation
{==============================================================================}
procedure WakeOnLan(MAC, IP: string);
var
sock: TUDPBlockSocket;
HexMac: Ansistring;
data: Ansistring;
n: integer;
b: Byte;
begin
if MAC <> '' then
begin
MAC := ReplaceString(MAC, '-', '');
MAC := ReplaceString(MAC, ':', '');
if Length(MAC) < 12 then
Exit;
HexMac := '';
for n := 0 to 5 do
begin
b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0);
HexMac := HexMac + char(b);
end;
if IP = '' then
IP := cBroadcast;
sock := TUDPBlockSocket.Create;
try
sock.CreateSocket;
sock.EnableBroadcast(true);
sock.Connect(IP, '9');
data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF;
for n := 1 to 16 do
data := data + HexMac;
sock.SendString(data);
finally
sock.Free;
end;
end;
end;
{==============================================================================}
{$IFNDEF UNIX}
function GetDNSbyIpHlp: string;
type
PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING;
TIP_ADDRESS_STRING = array[0..15] of Ansichar;
PTIP_ADDR_STRING = ^TIP_ADDR_STRING;
TIP_ADDR_STRING = packed record
Next: PTIP_ADDR_STRING;
IpAddress: TIP_ADDRESS_STRING;
IpMask: TIP_ADDRESS_STRING;
Context: DWORD;
end;
PTFixedInfo = ^TFixedInfo;
TFixedInfo = packed record
HostName: array[1..128 + 4] of Ansichar;
DomainName: array[1..128 + 4] of Ansichar;
CurrentDNSServer: PTIP_ADDR_STRING;
DNSServerList: TIP_ADDR_STRING;
NodeType: UINT;
ScopeID: array[1..256 + 4] of Ansichar;
EnableRouting: UINT;
EnableProxy: UINT;
EnableDNS: UINT;
end;
const
IpHlpDLL = 'IPHLPAPI.DLL';
var
IpHlpModule: THandle;
FixedInfo: PTFixedInfo;
InfoSize: Longint;
PDnsServer: PTIP_ADDR_STRING;
err: integer;
GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall;
begin
InfoSize := 0;
Result := '...';
IpHlpModule := LoadLibrary(IpHlpDLL);
if IpHlpModule = 0 then
exit;
try
GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams')));
if @GetNetworkParams = nil then
Exit;
err := GetNetworkParams(Nil, @InfoSize);
if err <> ERROR_BUFFER_OVERFLOW then
Exit;
Result := '';
GetMem (FixedInfo, InfoSize);
try
err := GetNetworkParams(FixedInfo, @InfoSize);
if err <> ERROR_SUCCESS then
exit;
with FixedInfo^ do
begin
Result := DnsServerList.IpAddress;
PDnsServer := DnsServerList.Next;
while PDnsServer <> Nil do
begin
if Result <> '' then
Result := Result + ',';
Result := Result + PDnsServer^.IPAddress;
PDnsServer := PDnsServer.Next;
end;
end;
finally
FreeMem(FixedInfo);
end;
finally
FreeLibrary(IpHlpModule);
end;
end;
function ReadReg(SubKey, Vn: PChar): string;
var
OpenKey: HKEY;
DataType, DataSize: integer;
Temp: array [0..2048] of char;
begin
Result := '';
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE,
KEY_READ, OpenKey) = ERROR_SUCCESS then
begin
DataType := REG_SZ;
DataSize := SizeOf(Temp);
if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then
SetString(Result, Temp, DataSize div SizeOf(Char) - 1);
RegCloseKey(OpenKey);
end;
end ;
{$ENDIF}
function GetDNS: string;
{$IFDEF UNIX}
var
l: TStringList;
n: integer;
begin
Result := '';
l := TStringList.Create;
try
l.LoadFromFile('/etc/resolv.conf');
for n := 0 to l.Count - 1 do
if Pos('NAMESERVER', uppercase(l[n])) = 1 then
begin
if Result <> '' then
Result := Result + ',';
Result := Result + SeparateRight(l[n], ' ');
end;
finally
l.Free;
end;
end;
{$ELSE}
const
NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary';
NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters';
W9xfix = 'System\CurrentControlSet\Services\MSTCP';
begin
Result := GetDNSbyIpHlp;
if Result = '...' then
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
Result := ReadReg(NTdyn, 'NameServer');
if result = '' then
Result := ReadReg(NTfix, 'NameServer');
if result = '' then
Result := ReadReg(NTfix, 'DhcpNameServer');
end
else
Result := ReadReg(W9xfix, 'NameServer');
Result := ReplaceString(trim(Result), ' ', ',');
end;
end;
{$ENDIF}
{==============================================================================}
function GetIEProxy(protocol: string): TProxySetting;
{$IFDEF UNIX}
begin
Result.Host := '';
Result.Port := '';
Result.Bypass := '';
end;
{$ELSE}
type
PInternetProxyInfo = ^TInternetProxyInfo;
TInternetProxyInfo = packed record
dwAccessType: DWORD;
lpszProxy: LPCSTR;
lpszProxyBypass: LPCSTR;
end;
const
INTERNET_OPTION_PROXY = 38;
INTERNET_OPEN_TYPE_PROXY = 3;
WininetDLL = 'WININET.DLL';
var
WininetModule: THandle;
ProxyInfo: PInternetProxyInfo;
Err: Boolean;
Len: DWORD;
Proxy: string;
DefProxy: string;
ProxyList: TStringList;
n: integer;
InternetQueryOption: function (hInet: Pointer; dwOption: DWORD;
lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall;
begin
Result.Host := '';
Result.Port := '';
Result.Bypass := '';
WininetModule := LoadLibrary(WininetDLL);
if WininetModule = 0 then
exit;
try
InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA')));
if @InternetQueryOption = nil then
Exit;
if protocol = '' then
protocol := 'http';
Len := 4096;
GetMem(ProxyInfo, Len);
ProxyList := TStringList.Create;
try
Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len);
if Err then
if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then
begin
ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ',');
Proxy := '';
DefProxy := '';
for n := 0 to ProxyList.Count -1 do
begin
if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then
begin
Proxy := SeparateRight(ProxyList[n], '=');
break;
end;
if Pos('=', ProxyList[n]) < 1 then
DefProxy := ProxyList[n];
end;
if Proxy = '' then
Proxy := DefProxy;
if Proxy <> '' then
begin
Result.Host := Trim(SeparateLeft(Proxy, ':'));
Result.Port := Trim(SeparateRight(Proxy, ':'));
end;
Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ',');
end;
finally
ProxyList.Free;
FreeMem(ProxyInfo);
end;
finally
FreeLibrary(WininetModule);
end;
end;
{$ENDIF}
{==============================================================================}
function GetLocalIPs: string;
var
TcpSock: TTCPBlockSocket;
ipList: TStringList;
begin
Result := '';
ipList := TStringList.Create;
try
TcpSock := TTCPBlockSocket.create;
try
TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList);
Result := ipList.CommaText;
finally
TcpSock.Free;
end;
finally
ipList.Free;
end;
end;
{==============================================================================}
end.

2339
synapse/synaser.pas Normal file
View File

File diff suppressed because it is too large Load Diff

2065
synapse/synautil.pas Normal file
View File

File diff suppressed because it is too large Load Diff

77
synapse/synsock.pas Normal file
View File

@ -0,0 +1,77 @@
{==============================================================================|
| Project : Ararat Synapse | 005.002.001 |
|==============================================================================|
| Content: Socket Independent Platform Layer |
|==============================================================================|
| Copyright (c)1999-2011, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2001-2011. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@exclude}
unit synsock;
{$MINENUMSIZE 4}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
{$IFNDEF MSWINDOWS}
{$DEFINE MSWINDOWS}
{$ENDIF}
{$ENDIF}
{$IFDEF CIL}
{$I ssdotnet.inc}
{$ELSE}
{$IFDEF MSWINDOWS}
{$I sswin32.inc}
{$ELSE}
{$IFDEF WINCE}
{$I sswin32.inc} //not complete yet!
{$ELSE}
{$IFDEF FPC}
{$I ssfpc.inc}
{$ELSE}
{$I sslinux.inc}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
end.

364
synapse/tlntsend.pas Normal file
View File

@ -0,0 +1,364 @@
{==============================================================================|
| Project : Ararat Synapse | 001.003.001 |
|==============================================================================|
| Content: TELNET and SSH2 client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2002-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract(Telnet script client)
Used RFC: RFC-854
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$H+}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$ENDIF}
unit tlntsend;
interface
uses
SysUtils, Classes,
blcksock, synautil;
const
cTelnetProtocol = '23';
cSSHProtocol = '22';
TLNT_EOR = #239;
TLNT_SE = #240;
TLNT_NOP = #241;
TLNT_DATA_MARK = #242;
TLNT_BREAK = #243;
TLNT_IP = #244;
TLNT_AO = #245;
TLNT_AYT = #246;
TLNT_EC = #247;
TLNT_EL = #248;
TLNT_GA = #249;
TLNT_SB = #250;
TLNT_WILL = #251;
TLNT_WONT = #252;
TLNT_DO = #253;
TLNT_DONT = #254;
TLNT_IAC = #255;
type
{:@abstract(State of telnet protocol). Used internaly by TTelnetSend.}
TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT,
tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC);
{:@abstract(Class with implementation of Telnet/SSH script client.)
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TTelnetSend = class(TSynaClient)
private
FSock: TTCPBlockSocket;
FBuffer: Ansistring;
FState: TTelnetState;
FSessionLog: Ansistring;
FSubNeg: Ansistring;
FSubType: Ansichar;
FTermType: Ansistring;
function Connect: Boolean;
function Negotiate(const Buf: Ansistring): Ansistring;
procedure FilterHook(Sender: TObject; var Value: AnsiString);
public
constructor Create;
destructor Destroy; override;
{:Connects to Telnet server.}
function Login: Boolean;
{:Connects to SSH2 server and login by Username and Password properties.
You must use some of SSL plugins with SSH support. For exammple CryptLib.}
function SSHLogin: Boolean;
{:Logout from telnet server.}
procedure Logout;
{:Send this data to telnet server.}
procedure Send(const Value: string);
{:Reading data from telnet server until Value is readed. If it is not readed
until timeout, result is @false. Otherwise result is @true.}
function WaitFor(const Value: string): Boolean;
{:Read data terminated by terminator from telnet server.}
function RecvTerminated(const Terminator: string): string;
{:Read string from telnet server.}
function RecvString: string;
published
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TTCPBlockSocket read FSock;
{:all readed datas in this session (from connect) is stored in this large
string.}
property SessionLog: Ansistring read FSessionLog write FSessionLog;
{:Terminal type indentification. By default is 'SYNAPSE'.}
property TermType: Ansistring read FTermType write FTermType;
end;
implementation
constructor TTelnetSend.Create;
begin
inherited Create;
FSock := TTCPBlockSocket.Create;
FSock.Owner := self;
FSock.OnReadFilter := FilterHook;
FTimeout := 60000;
FTargetPort := cTelnetProtocol;
FSubNeg := '';
FSubType := #0;
FTermType := 'SYNAPSE';
end;
destructor TTelnetSend.Destroy;
begin
FSock.Free;
inherited Destroy;
end;
function TTelnetSend.Connect: Boolean;
begin
// Do not call this function! It is calling by LOGIN method!
FBuffer := '';
FSessionLog := '';
FState := tsDATA;
FSock.CloseSocket;
FSock.LineBuffer := '';
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
Result := FSock.LastError = 0;
end;
function TTelnetSend.RecvTerminated(const Terminator: string): string;
begin
Result := FSock.RecvTerminated(FTimeout, Terminator);
end;
function TTelnetSend.RecvString: string;
begin
Result := FSock.RecvTerminated(FTimeout, CRLF);
end;
function TTelnetSend.WaitFor(const Value: string): Boolean;
begin
Result := FSock.RecvTerminated(FTimeout, Value) <> '';
end;
procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString);
begin
Value := Negotiate(Value);
FSessionLog := FSessionLog + Value;
end;
function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring;
var
n: integer;
c: Ansichar;
Reply: Ansistring;
SubReply: Ansistring;
begin
Result := '';
for n := 1 to Length(Buf) do
begin
c := Buf[n];
Reply := '';
case FState of
tsData:
if c = TLNT_IAC then
FState := tsIAC
else
Result := Result + c;
tsIAC:
case c of
TLNT_IAC:
begin
FState := tsData;
Result := Result + TLNT_IAC;
end;
TLNT_WILL:
FState := tsIAC_WILL;
TLNT_WONT:
FState := tsIAC_WONT;
TLNT_DONT:
FState := tsIAC_DONT;
TLNT_DO:
FState := tsIAC_DO;
TLNT_EOR:
FState := tsDATA;
TLNT_SB:
begin
FState := tsIAC_SB;
FSubType := #0;
FSubNeg := '';
end;
else
FState := tsData;
end;
tsIAC_WILL:
begin
case c of
#3: //suppress GA
Reply := TLNT_DO;
else
Reply := TLNT_DONT;
end;
FState := tsData;
end;
tsIAC_WONT:
begin
Reply := TLNT_DONT;
FState := tsData;
end;
tsIAC_DO:
begin
case c of
#24: //termtype
Reply := TLNT_WILL;
else
Reply := TLNT_WONT;
end;
FState := tsData;
end;
tsIAC_DONT:
begin
Reply := TLNT_WONT;
FState := tsData;
end;
tsIAC_SB:
begin
FSubType := c;
FState := tsIAC_SBDATA;
end;
tsIAC_SBDATA:
begin
if c = TLNT_IAC then
FState := tsSBDATA_IAC
else
FSubNeg := FSubNeg + c;
end;
tsSBDATA_IAC:
case c of
TLNT_IAC:
begin
FState := tsIAC_SBDATA;
FSubNeg := FSubNeg + c;
end;
TLNT_SE:
begin
SubReply := '';
case FSubType of
#24: //termtype
begin
if (FSubNeg <> '') and (FSubNeg[1] = #1) then
SubReply := #0 + FTermType;
end;
end;
Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE);
FState := tsDATA;
end;
else
FState := tsDATA;
end;
else
FState := tsData;
end;
if Reply <> '' then
Sock.SendString(TLNT_IAC + Reply + c);
end;
end;
procedure TTelnetSend.Send(const Value: string);
begin
Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC));
end;
function TTelnetSend.Login: Boolean;
begin
Result := False;
if not Connect then
Exit;
Result := True;
end;
function TTelnetSend.SSHLogin: Boolean;
begin
Result := False;
if Connect then
begin
FSock.SSL.SSLType := LT_SSHv2;
FSock.SSL.Username := FUsername;
FSock.SSL.Password := FPassword;
FSock.SSLDoConnect;
Result := FSock.LastError = 0;
end;
end;
procedure TTelnetSend.Logout;
begin
FSock.CloseSocket;
end;
end.