Initial commit
This commit is contained in:
commit
c128b16996
|
@ -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>.
|
|
@ -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.
|
|
@ -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 = (
|
||||
'"', '<', '>', 'ˆ', '˜', '£', '§', '°',
|
||||
'²', '³', 'µ', '·', '¼', '½', '¿',
|
||||
'À', 'Á', 'Â', 'Ã', 'Ä', 'Å', 'Æ',
|
||||
'Ç', 'È', 'É', 'Ê', 'Ë', 'Ì', 'Í',
|
||||
'Î', 'Ï', 'Ñ', 'Ò', 'Ó', 'Ô', 'Õ',
|
||||
'Ö', 'Ù', 'Ú', 'Û', 'Ü', 'Ý', 'ß',
|
||||
'á', 'à', 'â', 'ã', 'ä', 'å', 'æ',
|
||||
'ç', 'é', 'è', 'ê', 'ë', 'ì', 'í',
|
||||
'î', 'ï', 'ñ', 'ò', 'ó', 'ô', 'õ',
|
||||
'ö', '÷', 'ù', 'ú', 'û', 'ü', 'ý',
|
||||
'ÿ', '&', '´', '`');
|
||||
|
||||
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.
|
|
@ -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>
|
|
@ -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.
|
||||
|
|
@ -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.
|
File diff suppressed because it is too large
Load Diff
|
@ -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.
|
|
@ -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.
|
File diff suppressed because it is too large
Load Diff
|
@ -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.
|
|
@ -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.
|
|
@ -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.
|
|
@ -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>
|
|
@ -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.
|
File diff suppressed because it is too large
Load Diff
|
@ -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.
|
|
@ -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.
|
|
@ -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.
|
File diff suppressed because it is too large
Load Diff
|
@ -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.
|
|
@ -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.
|
|
@ -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.
|
|
@ -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.
|
|
@ -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.
|
File diff suppressed because it is too large
Load Diff
|
@ -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.
|
File diff suppressed because it is too large
Load Diff
|
@ -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}
|
||||
|
|
@ -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.
|
||||
|
||||
|
|
@ -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.
|
File diff suppressed because it is too large
Load Diff
|
@ -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.
|
|
@ -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.
|
||||
|
||||
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -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.
|
|
@ -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.
|
|
@ -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.
|
|
@ -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.
|
|
@ -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.
|
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
@ -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.
|
||||
|
|
@ -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.
|
Loading…
Reference in New Issue