├── LICENSE ├── README.md ├── edefines.inc ├── mqttClient.pas ├── nblocksock.pas ├── netdbn.pas └── synapse ├── asn1util.pas ├── blcksock.pas ├── clamsend.pas ├── dnssend.pas ├── ftpsend.pas ├── ftptsend.pas ├── httpsend.pas ├── imapsend.pas ├── ldapsend.pas ├── mimeinln.pas ├── mimemess.pas ├── mimepart.pas ├── nntpsend.pas ├── pingsend.pas ├── pop3send.pas ├── slogsend.pas ├── smtpsend.pas ├── snmpsend.pas ├── sntpsend.pas ├── ssdotnet.pas ├── ssfpc.pas ├── ssl_cryptlib.pas ├── ssl_openssl.pas ├── ssl_openssl_lib.pas ├── ssl_sbb.pas ├── ssl_streamsec.pas ├── sslinux.pas ├── sswin32.pas ├── synachar.pas ├── synacode.dcu ├── synacode.pas ├── synacrypt.pas ├── synadbg.pas ├── synafpc.pas ├── synaicnv.pas ├── synaip.pas ├── synamisc.pas ├── synaser.pas ├── synautil.pas ├── synsock.pas └── tlntsend.pas /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2019 Alexey Lutovinin 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![GitHub top language](https://img.shields.io/github/languages/top/crossrw/mqttClient.svg) 2 | ![GitHub code size in bytes](https://img.shields.io/github/languages/code-size/crossrw/mqttClient.svg) 3 | ![GitHub](https://img.shields.io/github/license/crossrw/mqttClient.svg) 4 | 5 | # mqttClient 6 | 7 | MQTT client for Delphi & FPC 8 | 9 | 10 | 11 | ## Limitations 12 | 13 | Not supported QOS (Quality Of Service) = 2. 14 | -------------------------------------------------------------------------------- /edefines.inc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crossrw/mqttClient/7f392ca2d692b119ecfb35c6b034f59c6640617d/edefines.inc -------------------------------------------------------------------------------- /nblocksock.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crossrw/mqttClient/7f392ca2d692b119ecfb35c6b034f59c6640617d/nblocksock.pas -------------------------------------------------------------------------------- /synapse/asn1util.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.004.004 | 3 | |==============================================================================| 4 | | Content: support for ASN.1 BER coding and decoding | 5 | |==============================================================================| 6 | | Copyright (c)1999-2003, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c) 1999-2003 | 37 | | Portions created by Hernan Sanchez are Copyright (c) 2000. | 38 | | All Rights Reserved. | 39 | |==============================================================================| 40 | | Contributor(s): | 41 | | Hernan Sanchez (hernan.sanchez@iname.com) | 42 | |==============================================================================| 43 | | History: see HISTORY.HTM from distribution package | 44 | | (Found at URL: http://www.ararat.cz/synapse/) | 45 | |==============================================================================} 46 | 47 | {: @abstract(Utilities for handling ASN.1 BER encoding) 48 | By this unit you can parse ASN.1 BER encoded data to elements or build back any 49 | elements to ASN.1 BER encoded buffer. You can dump ASN.1 BER encoded data to 50 | human readable form for easy debugging, too. 51 | 52 | Supported element types are: ASN1_BOOL, ASN1_INT, ASN1_OCTSTR, ASN1_NULL, 53 | ASN1_OBJID, ASN1_ENUM, ASN1_SEQ, ASN1_SETOF, ASN1_IPADDR, ASN1_COUNTER, 54 | ASN1_GAUGE, ASN1_TIMETICKS, ASN1_OPAQUE 55 | 56 | For sample of using, look to @link(TSnmpSend) or @link(TLdapSend)class. 57 | } 58 | 59 | {$Q-} 60 | {$H+} 61 | {$IFDEF FPC} 62 | {$MODE DELPHI} 63 | {$ENDIF} 64 | 65 | unit asn1util; 66 | 67 | interface 68 | 69 | uses 70 | SysUtils, Classes, synautil; 71 | 72 | const 73 | ASN1_BOOL = $01; 74 | ASN1_INT = $02; 75 | ASN1_OCTSTR = $04; 76 | ASN1_NULL = $05; 77 | ASN1_OBJID = $06; 78 | ASN1_ENUM = $0a; 79 | ASN1_SEQ = $30; 80 | ASN1_SETOF = $31; 81 | ASN1_IPADDR = $40; 82 | ASN1_COUNTER = $41; 83 | ASN1_GAUGE = $42; 84 | ASN1_TIMETICKS = $43; 85 | ASN1_OPAQUE = $44; 86 | 87 | {:Encodes OID item to binary form.} 88 | function ASNEncOIDItem(Value: Integer): AnsiString; 89 | 90 | {:Decodes an OID item of the next element in the "Buffer" from the "Start" 91 | position.} 92 | function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer; 93 | 94 | {:Encodes the length of ASN.1 element to binary.} 95 | function ASNEncLen(Len: Integer): AnsiString; 96 | 97 | {:Decodes length of next element in "Buffer" from the "Start" position.} 98 | function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; 99 | 100 | {:Encodes a signed integer to ASN.1 binary} 101 | function ASNEncInt(Value: Integer): AnsiString; 102 | 103 | {:Encodes unsigned integer into ASN.1 binary} 104 | function ASNEncUInt(Value: Integer): AnsiString; 105 | 106 | {:Encodes ASN.1 object to binary form.} 107 | function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; 108 | 109 | {:Beginning with the "Start" position, decode the ASN.1 item of the next element 110 | in "Buffer". Type of item is stored in "ValueType."} 111 | function ASNItem(var Start: Integer; const Buffer: AnsiString; 112 | var ValueType: Integer): AnsiString; 113 | 114 | {:Encodes an MIB OID string to binary form.} 115 | function MibToId(Mib: String): AnsiString; 116 | 117 | {:Decodes MIB OID from binary form to string form.} 118 | function IdToMib(const Id: AnsiString): String; 119 | 120 | {:Encodes an one number from MIB OID to binary form. (used internally from 121 | @link(MibToId))} 122 | function IntMibToStr(const Value: AnsiString): AnsiString; 123 | 124 | {:Convert ASN.1 BER encoded buffer to human readable form for debugging.} 125 | function ASNdump(const Value: AnsiString): AnsiString; 126 | 127 | implementation 128 | 129 | {==============================================================================} 130 | function ASNEncOIDItem(Value: Integer): AnsiString; 131 | var 132 | x, xm: Integer; 133 | b: Boolean; 134 | begin 135 | x := Value; 136 | b := False; 137 | Result := ''; 138 | repeat 139 | xm := x mod 128; 140 | x := x div 128; 141 | if b then 142 | xm := xm or $80; 143 | if x > 0 then 144 | b := True; 145 | Result := AnsiChar(xm) + Result; 146 | until x = 0; 147 | end; 148 | 149 | {==============================================================================} 150 | function ASNDecOIDItem(var Start: Integer; const Buffer: AnsiString): Integer; 151 | var 152 | x: Integer; 153 | b: Boolean; 154 | begin 155 | Result := 0; 156 | repeat 157 | Result := Result * 128; 158 | x := Ord(Buffer[Start]); 159 | Inc(Start); 160 | b := x > $7F; 161 | x := x and $7F; 162 | Result := Result + x; 163 | until not b; 164 | end; 165 | 166 | {==============================================================================} 167 | function ASNEncLen(Len: Integer): AnsiString; 168 | var 169 | x, y: Integer; 170 | begin 171 | if Len < $80 then 172 | Result := AnsiChar(Len) 173 | else 174 | begin 175 | x := Len; 176 | Result := ''; 177 | repeat 178 | y := x mod 256; 179 | x := x div 256; 180 | Result := AnsiChar(y) + Result; 181 | until x = 0; 182 | y := Length(Result); 183 | y := y or $80; 184 | Result := AnsiChar(y) + Result; 185 | end; 186 | end; 187 | 188 | {==============================================================================} 189 | function ASNDecLen(var Start: Integer; const Buffer: AnsiString): Integer; 190 | var 191 | x, n: Integer; 192 | begin 193 | x := Ord(Buffer[Start]); 194 | Inc(Start); 195 | if x < $80 then 196 | Result := x 197 | else 198 | begin 199 | Result := 0; 200 | x := x and $7F; 201 | for n := 1 to x do 202 | begin 203 | Result := Result * 256; 204 | x := Ord(Buffer[Start]); 205 | Inc(Start); 206 | Result := Result + x; 207 | end; 208 | end; 209 | end; 210 | 211 | {==============================================================================} 212 | function ASNEncInt(Value: Integer): AnsiString; 213 | var 214 | x, y: Cardinal; 215 | neg: Boolean; 216 | begin 217 | neg := Value < 0; 218 | x := Abs(Value); 219 | if neg then 220 | x := not (x - 1); 221 | Result := ''; 222 | repeat 223 | y := x mod 256; 224 | x := x div 256; 225 | Result := AnsiChar(y) + Result; 226 | until x = 0; 227 | if (not neg) and (Result[1] > #$7F) then 228 | Result := #0 + Result; 229 | end; 230 | 231 | {==============================================================================} 232 | function ASNEncUInt(Value: Integer): AnsiString; 233 | var 234 | x, y: Integer; 235 | neg: Boolean; 236 | begin 237 | neg := Value < 0; 238 | x := Value; 239 | if neg then 240 | x := x and $7FFFFFFF; 241 | Result := ''; 242 | repeat 243 | y := x mod 256; 244 | x := x div 256; 245 | Result := AnsiChar(y) + Result; 246 | until x = 0; 247 | if neg then 248 | Result[1] := AnsiChar(Ord(Result[1]) or $80); 249 | end; 250 | 251 | {==============================================================================} 252 | function ASNObject(const Data: AnsiString; ASNType: Integer): AnsiString; 253 | begin 254 | Result := AnsiChar(ASNType) + ASNEncLen(Length(Data)) + Data; 255 | end; 256 | 257 | {==============================================================================} 258 | function ASNItem(var Start: Integer; const Buffer: AnsiString; 259 | var ValueType: Integer): AnsiString; 260 | var 261 | ASNType: Integer; 262 | ASNSize: Integer; 263 | y, n: Integer; 264 | x: byte; 265 | s: AnsiString; 266 | c: AnsiChar; 267 | neg: Boolean; 268 | l: Integer; 269 | begin 270 | Result := ''; 271 | ValueType := ASN1_NULL; 272 | l := Length(Buffer); 273 | if l < (Start + 1) then 274 | Exit; 275 | ASNType := Ord(Buffer[Start]); 276 | ValueType := ASNType; 277 | Inc(Start); 278 | ASNSize := ASNDecLen(Start, Buffer); 279 | if (Start + ASNSize - 1) > l then 280 | Exit; 281 | if (ASNType and $20) > 0 then 282 | // Result := '$' + IntToHex(ASNType, 2) 283 | Result := Copy(Buffer, Start, ASNSize) 284 | else 285 | case ASNType of 286 | ASN1_INT, ASN1_ENUM, ASN1_BOOL: 287 | begin 288 | y := 0; 289 | neg := False; 290 | for n := 1 to ASNSize do 291 | begin 292 | x := Ord(Buffer[Start]); 293 | if (n = 1) and (x > $7F) then 294 | neg := True; 295 | if neg then 296 | x := not x; 297 | y := y * 256 + x; 298 | Inc(Start); 299 | end; 300 | if neg then 301 | y := -(y + 1); 302 | Result := IntToStr(y); 303 | end; 304 | ASN1_COUNTER, ASN1_GAUGE, ASN1_TIMETICKS: 305 | begin 306 | y := 0; 307 | for n := 1 to ASNSize do 308 | begin 309 | y := y * 256 + Ord(Buffer[Start]); 310 | Inc(Start); 311 | end; 312 | Result := IntToStr(y); 313 | end; 314 | ASN1_OCTSTR, ASN1_OPAQUE: 315 | begin 316 | for n := 1 to ASNSize do 317 | begin 318 | c := AnsiChar(Buffer[Start]); 319 | Inc(Start); 320 | s := s + c; 321 | end; 322 | Result := s; 323 | end; 324 | ASN1_OBJID: 325 | begin 326 | for n := 1 to ASNSize do 327 | begin 328 | c := AnsiChar(Buffer[Start]); 329 | Inc(Start); 330 | s := s + c; 331 | end; 332 | Result := IdToMib(s); 333 | end; 334 | ASN1_IPADDR: 335 | begin 336 | s := ''; 337 | for n := 1 to ASNSize do 338 | begin 339 | if (n <> 1) then 340 | s := s + '.'; 341 | y := Ord(Buffer[Start]); 342 | Inc(Start); 343 | s := s + IntToStr(y); 344 | end; 345 | Result := s; 346 | end; 347 | ASN1_NULL: 348 | begin 349 | Result := ''; 350 | Start := Start + ASNSize; 351 | end; 352 | else // unknown 353 | begin 354 | for n := 1 to ASNSize do 355 | begin 356 | c := AnsiChar(Buffer[Start]); 357 | Inc(Start); 358 | s := s + c; 359 | end; 360 | Result := s; 361 | end; 362 | end; 363 | end; 364 | 365 | {==============================================================================} 366 | function MibToId(Mib: String): AnsiString; 367 | var 368 | x: Integer; 369 | 370 | function WalkInt(var s: String): Integer; 371 | var 372 | x: Integer; 373 | t: AnsiString; 374 | begin 375 | x := Pos('.', s); 376 | if x < 1 then 377 | begin 378 | t := s; 379 | s := ''; 380 | end 381 | else 382 | begin 383 | t := Copy(s, 1, x - 1); 384 | s := Copy(s, x + 1, Length(s) - x); 385 | end; 386 | Result := StrToIntDef(t, 0); 387 | end; 388 | 389 | begin 390 | Result := ''; 391 | x := WalkInt(Mib); 392 | x := x * 40 + WalkInt(Mib); 393 | Result := ASNEncOIDItem(x); 394 | while Mib <> '' do 395 | begin 396 | x := WalkInt(Mib); 397 | Result := Result + ASNEncOIDItem(x); 398 | end; 399 | end; 400 | 401 | {==============================================================================} 402 | function IdToMib(const Id: AnsiString): String; 403 | var 404 | x, y, n: Integer; 405 | begin 406 | Result := ''; 407 | n := 1; 408 | while Length(Id) + 1 > n do 409 | begin 410 | x := ASNDecOIDItem(n, Id); 411 | if (n - 1) = 1 then 412 | begin 413 | y := x div 40; 414 | x := x mod 40; 415 | Result := IntToStr(y); 416 | end; 417 | Result := Result + '.' + IntToStr(x); 418 | end; 419 | end; 420 | 421 | {==============================================================================} 422 | function IntMibToStr(const Value: AnsiString): AnsiString; 423 | var 424 | n, y: Integer; 425 | begin 426 | y := 0; 427 | for n := 1 to Length(Value) - 1 do 428 | y := y * 256 + Ord(Value[n]); 429 | Result := IntToStr(y); 430 | end; 431 | 432 | {==============================================================================} 433 | function ASNdump(const Value: AnsiString): AnsiString; 434 | var 435 | i, at, x, n: integer; 436 | s, indent: AnsiString; 437 | il: TStringList; 438 | begin 439 | il := TStringList.Create; 440 | try 441 | Result := ''; 442 | i := 1; 443 | indent := ''; 444 | while i < Length(Value) do 445 | begin 446 | for n := il.Count - 1 downto 0 do 447 | begin 448 | x := StrToIntDef(il[n], 0); 449 | if x <= i then 450 | begin 451 | il.Delete(n); 452 | Delete(indent, 1, 2); 453 | end; 454 | end; 455 | s := ASNItem(i, Value, at); 456 | Result := Result + indent + '$' + IntToHex(at, 2); 457 | if (at and $20) > 0 then 458 | begin 459 | x := Length(s); 460 | Result := Result + ' constructed: length ' + IntToStr(x); 461 | indent := indent + ' '; 462 | il.Add(IntToStr(x + i - 1)); 463 | end 464 | else 465 | begin 466 | case at of 467 | ASN1_BOOL: 468 | Result := Result + ' BOOL: '; 469 | ASN1_INT: 470 | Result := Result + ' INT: '; 471 | ASN1_ENUM: 472 | Result := Result + ' ENUM: '; 473 | ASN1_COUNTER: 474 | Result := Result + ' COUNTER: '; 475 | ASN1_GAUGE: 476 | Result := Result + ' GAUGE: '; 477 | ASN1_TIMETICKS: 478 | Result := Result + ' TIMETICKS: '; 479 | ASN1_OCTSTR: 480 | Result := Result + ' OCTSTR: '; 481 | ASN1_OPAQUE: 482 | Result := Result + ' OPAQUE: '; 483 | ASN1_OBJID: 484 | Result := Result + ' OBJID: '; 485 | ASN1_IPADDR: 486 | Result := Result + ' IPADDR: '; 487 | ASN1_NULL: 488 | Result := Result + ' NULL: '; 489 | else // other 490 | Result := Result + ' unknown: '; 491 | end; 492 | if IsBinaryString(s) then 493 | s := DumpExStr(s); 494 | Result := Result + s; 495 | end; 496 | Result := Result + #$0d + #$0a; 497 | end; 498 | finally 499 | il.Free; 500 | end; 501 | end; 502 | 503 | {==============================================================================} 504 | 505 | end. 506 | -------------------------------------------------------------------------------- /synapse/clamsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.000 | 3 | |==============================================================================| 4 | | Content: ClamAV-daemon client | 5 | |==============================================================================| 6 | | Copyright (c)2005-2009, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2005-2009. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract( ClamAV-daemon client) 46 | 47 | This unit is capable to do antivirus scan of your data by TCP channel to ClamD 48 | daemon from ClamAV. See more about ClamAV on @LINK(http://www.clamav.net) 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$Q-} 55 | {$H+} 56 | 57 | unit clamsend; 58 | 59 | interface 60 | 61 | uses 62 | SysUtils, Classes, 63 | synsock, blcksock, synautil; 64 | 65 | const 66 | cClamProtocol = '3310'; 67 | 68 | type 69 | 70 | {:@abstract(Implementation of ClamAV-daemon client protocol) 71 | By this class you can scan any your data by ClamAV opensource antivirus. 72 | 73 | This class can connect to ClamD by TCP channel, send your data to ClamD 74 | and read result.} 75 | TClamSend = class(TSynaClient) 76 | private 77 | FSock: TTCPBlockSocket; 78 | FDSock: TTCPBlockSocket; 79 | FSession: boolean; 80 | function Login: boolean; virtual; 81 | function Logout: Boolean; virtual; 82 | function OpenStream: Boolean; virtual; 83 | public 84 | constructor Create; 85 | destructor Destroy; override; 86 | 87 | {:Call any command to ClamD. Used internally by other methods.} 88 | function DoCommand(const Value: AnsiString): AnsiString; virtual; 89 | 90 | {:Return ClamAV version and version of loaded databases.} 91 | function GetVersion: AnsiString; virtual; 92 | 93 | {:Scan content of TStrings.} 94 | function ScanStrings(const Value: TStrings): AnsiString; virtual; 95 | 96 | {:Scan content of TStream.} 97 | function ScanStream(const Value: TStream): AnsiString; virtual; 98 | 99 | {:Scan content of TStrings by new 0.95 API.} 100 | function ScanStrings2(const Value: TStrings): AnsiString; virtual; 101 | 102 | {:Scan content of TStream by new 0.95 API.} 103 | function ScanStream2(const Value: TStream): AnsiString; virtual; 104 | published 105 | {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} 106 | property Sock: TTCPBlockSocket read FSock; 107 | 108 | {:Socket object used for TCP data transfer operation. Good for seting OnStatus hook, etc.} 109 | property DSock: TTCPBlockSocket read FDSock; 110 | 111 | {:Can turn-on session mode of communication with ClamD. Default is @false, 112 | because ClamAV developers design their TCP code very badly and session mode 113 | is broken now (CVS-20051031). Maybe ClamAV developers fix their bugs 114 | and this mode will be possible in future.} 115 | property Session: boolean read FSession write FSession; 116 | end; 117 | 118 | implementation 119 | 120 | constructor TClamSend.Create; 121 | begin 122 | inherited Create; 123 | FSock := TTCPBlockSocket.Create; 124 | FDSock := TTCPBlockSocket.Create; 125 | FTimeout := 60000; 126 | FTargetPort := cClamProtocol; 127 | FSession := false; 128 | end; 129 | 130 | destructor TClamSend.Destroy; 131 | begin 132 | Logout; 133 | FDSock.Free; 134 | FSock.Free; 135 | inherited Destroy; 136 | end; 137 | 138 | function TClamSend.DoCommand(const Value: AnsiString): AnsiString; 139 | begin 140 | Result := ''; 141 | if not FSession then 142 | FSock.CloseSocket 143 | else 144 | FSock.SendString(Value + LF); 145 | if not FSession or (FSock.LastError <> 0) then 146 | begin 147 | if Login then 148 | FSock.SendString(Value + LF) 149 | else 150 | Exit; 151 | end; 152 | Result := FSock.RecvTerminated(FTimeout, LF); 153 | end; 154 | 155 | function TClamSend.Login: boolean; 156 | begin 157 | Result := False; 158 | Sock.CloseSocket; 159 | FSock.Bind(FIPInterface, cAnyPort); 160 | if FSock.LastError <> 0 then 161 | Exit; 162 | FSock.Connect(FTargetHost, FTargetPort); 163 | if FSock.LastError <> 0 then 164 | Exit; 165 | if FSession then 166 | FSock.SendString('SESSION' + LF); 167 | Result := FSock.LastError = 0; 168 | end; 169 | 170 | function TClamSend.Logout: Boolean; 171 | begin 172 | FSock.SendString('END' + LF); 173 | Result := FSock.LastError = 0; 174 | FSock.CloseSocket; 175 | end; 176 | 177 | function TClamSend.GetVersion: AnsiString; 178 | begin 179 | Result := DoCommand('nVERSION'); 180 | end; 181 | 182 | function TClamSend.OpenStream: Boolean; 183 | var 184 | S: AnsiString; 185 | begin 186 | Result := False; 187 | s := DoCommand('nSTREAM'); 188 | if (s <> '') and (Copy(s, 1, 4) = 'PORT') then 189 | begin 190 | s := SeparateRight(s, ' '); 191 | FDSock.CloseSocket; 192 | FDSock.Bind(FIPInterface, cAnyPort); 193 | if FDSock.LastError <> 0 then 194 | Exit; 195 | FDSock.Connect(FTargetHost, s); 196 | if FDSock.LastError <> 0 then 197 | Exit; 198 | Result := True; 199 | end; 200 | end; 201 | 202 | function TClamSend.ScanStrings(const Value: TStrings): AnsiString; 203 | begin 204 | Result := ''; 205 | if OpenStream then 206 | begin 207 | DSock.SendString(Value.Text); 208 | DSock.CloseSocket; 209 | Result := FSock.RecvTerminated(FTimeout, LF); 210 | end; 211 | end; 212 | 213 | function TClamSend.ScanStream(const Value: TStream): AnsiString; 214 | begin 215 | Result := ''; 216 | if OpenStream then 217 | begin 218 | DSock.SendStreamRaw(Value); 219 | DSock.CloseSocket; 220 | Result := FSock.RecvTerminated(FTimeout, LF); 221 | end; 222 | end; 223 | 224 | function TClamSend.ScanStrings2(const Value: TStrings): AnsiString; 225 | var 226 | i: integer; 227 | s: AnsiString; 228 | begin 229 | Result := ''; 230 | if not FSession then 231 | FSock.CloseSocket 232 | else 233 | FSock.sendstring('nINSTREAM' + LF); 234 | if not FSession or (FSock.LastError <> 0) then 235 | begin 236 | if Login then 237 | FSock.sendstring('nINSTREAM' + LF) 238 | else 239 | Exit; 240 | end; 241 | s := Value.text; 242 | i := length(s); 243 | FSock.SendString(CodeLongint(i) + s + #0#0#0#0); 244 | Result := FSock.RecvTerminated(FTimeout, LF); 245 | end; 246 | 247 | function TClamSend.ScanStream2(const Value: TStream): AnsiString; 248 | var 249 | i: integer; 250 | s: AnsiString; 251 | begin 252 | Result := ''; 253 | if not FSession then 254 | FSock.CloseSocket 255 | else 256 | FSock.sendstring('nINSTREAM' + LF); 257 | if not FSession or (FSock.LastError <> 0) then 258 | begin 259 | if Login then 260 | FSock.sendstring('nINSTREAM' + LF) 261 | else 262 | Exit; 263 | end; 264 | i := value.Size; 265 | FSock.SendString(CodeLongint(i)); 266 | FSock.SendStreamRaw(Value); 267 | FSock.SendString(#0#0#0#0); 268 | Result := FSock.RecvTerminated(FTimeout, LF); 269 | end; 270 | 271 | end. 272 | -------------------------------------------------------------------------------- /synapse/dnssend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 002.007.004 | 3 | |==============================================================================| 4 | | Content: DNS client | 5 | |==============================================================================| 6 | | Copyright (c)1999-2007, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2000-2007. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | {: @abstract(DNS client by UDP or TCP) 45 | Support for sending DNS queries by UDP or TCP protocol. It can retrieve zone 46 | transfers too! 47 | 48 | Used RFC: RFC-1035, RFC-1183, RFC1706, RFC1712, RFC2163, RFC2230 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$Q-} 55 | {$H+} 56 | 57 | unit dnssend; 58 | 59 | interface 60 | 61 | uses 62 | SysUtils, Classes, 63 | blcksock, synautil, synaip, synsock; 64 | 65 | const 66 | cDnsProtocol = '53'; 67 | 68 | QTYPE_A = 1; 69 | QTYPE_NS = 2; 70 | QTYPE_MD = 3; 71 | QTYPE_MF = 4; 72 | QTYPE_CNAME = 5; 73 | QTYPE_SOA = 6; 74 | QTYPE_MB = 7; 75 | QTYPE_MG = 8; 76 | QTYPE_MR = 9; 77 | QTYPE_NULL = 10; 78 | QTYPE_WKS = 11; // 79 | QTYPE_PTR = 12; 80 | QTYPE_HINFO = 13; 81 | QTYPE_MINFO = 14; 82 | QTYPE_MX = 15; 83 | QTYPE_TXT = 16; 84 | 85 | QTYPE_RP = 17; 86 | QTYPE_AFSDB = 18; 87 | QTYPE_X25 = 19; 88 | QTYPE_ISDN = 20; 89 | QTYPE_RT = 21; 90 | QTYPE_NSAP = 22; 91 | QTYPE_NSAPPTR = 23; 92 | QTYPE_SIG = 24; // RFC-2065 93 | QTYPE_KEY = 25; // RFC-2065 94 | QTYPE_PX = 26; 95 | QTYPE_GPOS = 27; 96 | QTYPE_AAAA = 28; 97 | QTYPE_LOC = 29; // RFC-1876 98 | QTYPE_NXT = 30; // RFC-2065 99 | 100 | QTYPE_SRV = 33; 101 | QTYPE_NAPTR = 35; // RFC-2168 102 | QTYPE_KX = 36; 103 | QTYPE_SPF = 99; 104 | 105 | QTYPE_AXFR = 252; 106 | QTYPE_MAILB = 253; // 107 | QTYPE_MAILA = 254; // 108 | QTYPE_ALL = 255; 109 | 110 | type 111 | {:@abstract(Implementation of DNS protocol by UDP or TCP protocol.) 112 | 113 | Note: Are you missing properties for specify server address and port? Look to 114 | parent @link(TSynaClient) too!} 115 | TDNSSend = class(TSynaClient) 116 | private 117 | FID: Word; 118 | FRCode: Integer; 119 | FBuffer: AnsiString; 120 | FSock: TUDPBlockSocket; 121 | FTCPSock: TTCPBlockSocket; 122 | FUseTCP: Boolean; 123 | FAnswerInfo: TStringList; 124 | FNameserverInfo: TStringList; 125 | FAdditionalInfo: TStringList; 126 | FAuthoritative: Boolean; 127 | FTruncated: Boolean; 128 | function CompressName(const Value: AnsiString): AnsiString; 129 | function CodeHeader: AnsiString; 130 | function CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; 131 | function DecodeLabels(var From: Integer): AnsiString; 132 | function DecodeString(var From: Integer): AnsiString; 133 | function DecodeResource(var i: Integer; const Info: TStringList; 134 | QType: Integer): AnsiString; 135 | function RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; 136 | function DecodeResponse(const Buf: AnsiString; const Reply: TStrings; 137 | QType: Integer):boolean; 138 | public 139 | constructor Create; 140 | destructor Destroy; override; 141 | 142 | {:Query a DNSHost for QType resources correspond to a name. Supported QType 143 | values are: Qtype_A, Qtype_NS, Qtype_MD, Qtype_MF, Qtype_CNAME, Qtype_SOA, 144 | Qtype_MB, Qtype_MG, Qtype_MR, Qtype_NULL, Qtype_PTR, Qtype_HINFO, 145 | Qtype_MINFO, Qtype_MX, Qtype_TXT, Qtype_RP, Qtype_AFSDB, Qtype_X25, 146 | Qtype_ISDN, Qtype_RT, Qtype_NSAP, Qtype_NSAPPTR, Qtype_PX, Qtype_GPOS, 147 | Qtype_KX. 148 | 149 | Type for zone transfers QTYPE_AXFR is supported too, but only in TCP mode! 150 | 151 | "Name" is domain name or host name for queried resource. If "name" is 152 | IP address, automatically convert to reverse domain form (.in-addr.arpa). 153 | 154 | If result is @true, Reply contains resource records. One record on one line. 155 | If Resource record have multiple fields, they are stored on line divided by 156 | comma. (example: MX record contains value 'rs.cesnet.cz' with preference 157 | number 10, string in Reply is: '10,rs.cesnet.cz'). All numbers or IP address 158 | in resource are converted to string form.} 159 | function DNSQuery(Name: AnsiString; QType: Integer; 160 | const Reply: TStrings): Boolean; 161 | published 162 | 163 | {:Socket object used for UDP operation. Good for seting OnStatus hook, etc.} 164 | property Sock: TUDPBlockSocket read FSock; 165 | 166 | {:Socket object used for TCP operation. Good for seting OnStatus hook, etc.} 167 | property TCPSock: TTCPBlockSocket read FTCPSock; 168 | 169 | {:if @true, then is used TCP protocol instead UDP. It is needed for zone 170 | transfers, etc.} 171 | property UseTCP: Boolean read FUseTCP Write FUseTCP; 172 | 173 | {:After DNS operation contains ResultCode of DNS operation. 174 | Values are: 0-no error, 1-format error, 2-server failure, 3-name error, 175 | 4-not implemented, 5-refused.} 176 | property RCode: Integer read FRCode; 177 | 178 | {:@True, if answer is authoritative.} 179 | property Authoritative: Boolean read FAuthoritative; 180 | 181 | {:@True, if answer is truncated to 512 bytes.} 182 | property Truncated: Boolean read FTRuncated; 183 | 184 | {:Detailed informations from name server reply. One record per line. Record 185 | have comma delimited entries with type number, TTL and data filelds. 186 | This information contains detailed information about query reply.} 187 | property AnswerInfo: TStringList read FAnswerInfo; 188 | 189 | {:Detailed informations from name server reply. One record per line. Record 190 | have comma delimited entries with type number, TTL and data filelds. 191 | This information contains detailed information about nameserver.} 192 | property NameserverInfo: TStringList read FNameserverInfo; 193 | 194 | {:Detailed informations from name server reply. One record per line. Record 195 | have comma delimited entries with type number, TTL and data filelds. 196 | This information contains detailed additional information.} 197 | property AdditionalInfo: TStringList read FAdditionalInfo; 198 | end; 199 | 200 | {:A very useful function, and example of it's use is found in the TDNSSend object. 201 | This function is used to get mail servers for a domain and sort them by 202 | preference numbers. "Servers" contains only the domain names of the mail 203 | servers in the right order (without preference number!). The first domain name 204 | will always be the highest preferenced mail server. Returns boolean @TRUE if 205 | all went well.} 206 | function GetMailServers(const DNSHost, Domain: AnsiString; 207 | const Servers: TStrings): Boolean; 208 | 209 | implementation 210 | 211 | constructor TDNSSend.Create; 212 | begin 213 | inherited Create; 214 | FSock := TUDPBlockSocket.Create; 215 | FTCPSock := TTCPBlockSocket.Create; 216 | FUseTCP := False; 217 | FTimeout := 10000; 218 | FTargetPort := cDnsProtocol; 219 | FAnswerInfo := TStringList.Create; 220 | FNameserverInfo := TStringList.Create; 221 | FAdditionalInfo := TStringList.Create; 222 | Randomize; 223 | end; 224 | 225 | destructor TDNSSend.Destroy; 226 | begin 227 | FAnswerInfo.Free; 228 | FNameserverInfo.Free; 229 | FAdditionalInfo.Free; 230 | FTCPSock.Free; 231 | FSock.Free; 232 | inherited Destroy; 233 | end; 234 | 235 | function TDNSSend.CompressName(const Value: AnsiString): AnsiString; 236 | var 237 | n: Integer; 238 | s: AnsiString; 239 | begin 240 | Result := ''; 241 | if Value = '' then 242 | Result := #0 243 | else 244 | begin 245 | s := ''; 246 | for n := 1 to Length(Value) do 247 | if Value[n] = '.' then 248 | begin 249 | Result := Result + Char(Length(s)) + s; 250 | s := ''; 251 | end 252 | else 253 | s := s + Value[n]; 254 | if s <> '' then 255 | Result := Result + Char(Length(s)) + s; 256 | Result := Result + #0; 257 | end; 258 | end; 259 | 260 | function TDNSSend.CodeHeader: AnsiString; 261 | begin 262 | FID := Random(32767); 263 | Result := CodeInt(FID); // ID 264 | Result := Result + CodeInt($0100); // flags 265 | Result := Result + CodeInt(1); // QDCount 266 | Result := Result + CodeInt(0); // ANCount 267 | Result := Result + CodeInt(0); // NSCount 268 | Result := Result + CodeInt(0); // ARCount 269 | end; 270 | 271 | function TDNSSend.CodeQuery(const Name: AnsiString; QType: Integer): AnsiString; 272 | begin 273 | Result := CompressName(Name); 274 | Result := Result + CodeInt(QType); 275 | Result := Result + CodeInt(1); // Type INTERNET 276 | end; 277 | 278 | function TDNSSend.DecodeString(var From: Integer): AnsiString; 279 | var 280 | Len: integer; 281 | begin 282 | Len := Ord(FBuffer[From]); 283 | Inc(From); 284 | Result := Copy(FBuffer, From, Len); 285 | Inc(From, Len); 286 | end; 287 | 288 | function TDNSSend.DecodeLabels(var From: Integer): AnsiString; 289 | var 290 | l, f: Integer; 291 | begin 292 | Result := ''; 293 | while True do 294 | begin 295 | if From >= Length(FBuffer) then 296 | Break; 297 | l := Ord(FBuffer[From]); 298 | Inc(From); 299 | if l = 0 then 300 | Break; 301 | if Result <> '' then 302 | Result := Result + '.'; 303 | if (l and $C0) = $C0 then 304 | begin 305 | f := l and $3F; 306 | f := f * 256 + Ord(FBuffer[From]) + 1; 307 | Inc(From); 308 | Result := Result + DecodeLabels(f); 309 | Break; 310 | end 311 | else 312 | begin 313 | Result := Result + Copy(FBuffer, From, l); 314 | Inc(From, l); 315 | end; 316 | end; 317 | end; 318 | 319 | function TDNSSend.DecodeResource(var i: Integer; const Info: TStringList; 320 | QType: Integer): AnsiString; 321 | var 322 | Rname: AnsiString; 323 | RType, Len, j, x, y, z, n: Integer; 324 | R: AnsiString; 325 | t1, t2, ttl: integer; 326 | ip6: TIp6bytes; 327 | begin 328 | Result := ''; 329 | R := ''; 330 | Rname := DecodeLabels(i); 331 | RType := DecodeInt(FBuffer, i); 332 | Inc(i, 4); 333 | t1 := DecodeInt(FBuffer, i); 334 | Inc(i, 2); 335 | t2 := DecodeInt(FBuffer, i); 336 | Inc(i, 2); 337 | ttl := t1 * 65536 + t2; 338 | Len := DecodeInt(FBuffer, i); 339 | Inc(i, 2); // i point to begin of data 340 | j := i; 341 | i := i + len; // i point to next record 342 | if Length(FBuffer) >= (i - 1) then 343 | case RType of 344 | QTYPE_A: 345 | begin 346 | R := IntToStr(Ord(FBuffer[j])); 347 | Inc(j); 348 | R := R + '.' + IntToStr(Ord(FBuffer[j])); 349 | Inc(j); 350 | R := R + '.' + IntToStr(Ord(FBuffer[j])); 351 | Inc(j); 352 | R := R + '.' + IntToStr(Ord(FBuffer[j])); 353 | end; 354 | QTYPE_AAAA: 355 | begin 356 | for n := 0 to 15 do 357 | ip6[n] := ord(FBuffer[j + n]); 358 | R := IP6ToStr(ip6); 359 | end; 360 | QTYPE_NS, QTYPE_MD, QTYPE_MF, QTYPE_CNAME, QTYPE_MB, 361 | QTYPE_MG, QTYPE_MR, QTYPE_PTR, QTYPE_X25, QTYPE_NSAP, 362 | QTYPE_NSAPPTR: 363 | R := DecodeLabels(j); 364 | QTYPE_SOA: 365 | begin 366 | R := DecodeLabels(j); 367 | R := R + ',' + DecodeLabels(j); 368 | for n := 1 to 5 do 369 | begin 370 | x := DecodeInt(FBuffer, j) * 65536 + DecodeInt(FBuffer, j + 2); 371 | Inc(j, 4); 372 | R := R + ',' + IntToStr(x); 373 | end; 374 | end; 375 | QTYPE_NULL: 376 | begin 377 | end; 378 | QTYPE_WKS: 379 | begin 380 | end; 381 | QTYPE_HINFO: 382 | begin 383 | R := DecodeString(j); 384 | R := R + ',' + DecodeString(j); 385 | end; 386 | QTYPE_MINFO, QTYPE_RP, QTYPE_ISDN: 387 | begin 388 | R := DecodeLabels(j); 389 | R := R + ',' + DecodeLabels(j); 390 | end; 391 | QTYPE_MX, QTYPE_AFSDB, QTYPE_RT, QTYPE_KX: 392 | begin 393 | x := DecodeInt(FBuffer, j); 394 | Inc(j, 2); 395 | R := IntToStr(x); 396 | R := R + ',' + DecodeLabels(j); 397 | end; 398 | QTYPE_TXT, QTYPE_SPF: 399 | begin 400 | R := ''; 401 | while j < i do 402 | R := R + DecodeString(j); 403 | end; 404 | QTYPE_GPOS: 405 | begin 406 | R := DecodeLabels(j); 407 | R := R + ',' + DecodeLabels(j); 408 | R := R + ',' + DecodeLabels(j); 409 | end; 410 | QTYPE_PX: 411 | begin 412 | x := DecodeInt(FBuffer, j); 413 | Inc(j, 2); 414 | R := IntToStr(x); 415 | R := R + ',' + DecodeLabels(j); 416 | R := R + ',' + DecodeLabels(j); 417 | end; 418 | QTYPE_SRV: 419 | // Author: Dan 420 | begin 421 | x := DecodeInt(FBuffer, j); 422 | Inc(j, 2); 423 | y := DecodeInt(FBuffer, j); 424 | Inc(j, 2); 425 | z := DecodeInt(FBuffer, j); 426 | Inc(j, 2); 427 | R := IntToStr(x); // Priority 428 | R := R + ',' + IntToStr(y); // Weight 429 | R := R + ',' + IntToStr(z); // Port 430 | R := R + ',' + DecodeLabels(j); // Server DNS Name 431 | end; 432 | end; 433 | if R <> '' then 434 | Info.Add(RName + ',' + IntToStr(RType) + ',' + IntToStr(ttl) + ',' + R); 435 | if QType = RType then 436 | Result := R; 437 | end; 438 | 439 | function TDNSSend.RecvTCPResponse(const WorkSock: TBlockSocket): AnsiString; 440 | var 441 | l: integer; 442 | begin 443 | Result := ''; 444 | l := WorkSock.recvbyte(FTimeout) * 256 + WorkSock.recvbyte(FTimeout); 445 | if l > 0 then 446 | Result := WorkSock.RecvBufferStr(l, FTimeout); 447 | end; 448 | 449 | function TDNSSend.DecodeResponse(const Buf: AnsiString; const Reply: TStrings; 450 | QType: Integer):boolean; 451 | var 452 | n, i: Integer; 453 | flag, qdcount, ancount, nscount, arcount: Integer; 454 | s: AnsiString; 455 | begin 456 | Result := False; 457 | Reply.Clear; 458 | FAnswerInfo.Clear; 459 | FNameserverInfo.Clear; 460 | FAdditionalInfo.Clear; 461 | FAuthoritative := False; 462 | if (Length(Buf) > 13) and (FID = DecodeInt(Buf, 1)) then 463 | begin 464 | Result := True; 465 | flag := DecodeInt(Buf, 3); 466 | FRCode := Flag and $000F; 467 | FAuthoritative := (Flag and $0400) > 0; 468 | FTruncated := (Flag and $0200) > 0; 469 | if FRCode = 0 then 470 | begin 471 | qdcount := DecodeInt(Buf, 5); 472 | ancount := DecodeInt(Buf, 7); 473 | nscount := DecodeInt(Buf, 9); 474 | arcount := DecodeInt(Buf, 11); 475 | i := 13; //begin of body 476 | if (qdcount > 0) and (Length(Buf) > i) then //skip questions 477 | for n := 1 to qdcount do 478 | begin 479 | while (Buf[i] <> #0) and ((Ord(Buf[i]) and $C0) <> $C0) do 480 | Inc(i); 481 | Inc(i, 5); 482 | end; 483 | if (ancount > 0) and (Length(Buf) > i) then // decode reply 484 | for n := 1 to ancount do 485 | begin 486 | s := DecodeResource(i, FAnswerInfo, QType); 487 | if s <> '' then 488 | Reply.Add(s); 489 | end; 490 | if (nscount > 0) and (Length(Buf) > i) then // decode nameserver info 491 | for n := 1 to nscount do 492 | DecodeResource(i, FNameserverInfo, QType); 493 | if (arcount > 0) and (Length(Buf) > i) then // decode additional info 494 | for n := 1 to arcount do 495 | DecodeResource(i, FAdditionalInfo, QType); 496 | end; 497 | end; 498 | end; 499 | 500 | function TDNSSend.DNSQuery(Name: AnsiString; QType: Integer; 501 | const Reply: TStrings): Boolean; 502 | var 503 | WorkSock: TBlockSocket; 504 | t: TStringList; 505 | b: boolean; 506 | begin 507 | Result := False; 508 | if IsIP(Name) then 509 | Name := ReverseIP(Name) + '.in-addr.arpa'; 510 | if IsIP6(Name) then 511 | Name := ReverseIP6(Name) + '.ip6.arpa'; 512 | FBuffer := CodeHeader + CodeQuery(Name, QType); 513 | if FUseTCP then 514 | WorkSock := FTCPSock 515 | else 516 | WorkSock := FSock; 517 | WorkSock.Bind(FIPInterface, cAnyPort); 518 | WorkSock.Connect(FTargetHost, FTargetPort); 519 | if FUseTCP then 520 | FBuffer := Codeint(length(FBuffer)) + FBuffer; 521 | WorkSock.SendString(FBuffer); 522 | if FUseTCP then 523 | FBuffer := RecvTCPResponse(WorkSock) 524 | else 525 | FBuffer := WorkSock.RecvPacket(FTimeout); 526 | if FUseTCP and (QType = QTYPE_AXFR) then //zone transfer 527 | begin 528 | t := TStringList.Create; 529 | try 530 | repeat 531 | b := DecodeResponse(FBuffer, Reply, QType); 532 | if (t.Count > 1) and (AnswerInfo.Count > 0) then //find end of transfer 533 | b := b and (t[0] <> AnswerInfo[AnswerInfo.count - 1]); 534 | if b then 535 | begin 536 | t.AddStrings(AnswerInfo); 537 | FBuffer := RecvTCPResponse(WorkSock); 538 | if FBuffer = '' then 539 | Break; 540 | if WorkSock.LastError <> 0 then 541 | Break; 542 | end; 543 | until not b; 544 | Reply.Assign(t); 545 | Result := True; 546 | finally 547 | t.free; 548 | end; 549 | end 550 | else //normal query 551 | if WorkSock.LastError = 0 then 552 | Result := DecodeResponse(FBuffer, Reply, QType); 553 | end; 554 | 555 | {==============================================================================} 556 | 557 | function GetMailServers(const DNSHost, Domain: AnsiString; 558 | const Servers: TStrings): Boolean; 559 | var 560 | DNS: TDNSSend; 561 | t: TStringList; 562 | n, m, x: Integer; 563 | begin 564 | Result := False; 565 | Servers.Clear; 566 | t := TStringList.Create; 567 | DNS := TDNSSend.Create; 568 | try 569 | DNS.TargetHost := DNSHost; 570 | if DNS.DNSQuery(Domain, QType_MX, t) then 571 | begin 572 | { normalize preference number to 5 digits } 573 | for n := 0 to t.Count - 1 do 574 | begin 575 | x := Pos(',', t[n]); 576 | if x > 0 then 577 | for m := 1 to 6 - x do 578 | t[n] := '0' + t[n]; 579 | end; 580 | { sort server list } 581 | t.Sorted := True; 582 | { result is sorted list without preference numbers } 583 | for n := 0 to t.Count - 1 do 584 | begin 585 | x := Pos(',', t[n]); 586 | Servers.Add(Copy(t[n], x + 1, Length(t[n]) - x)); 587 | end; 588 | Result := True; 589 | end; 590 | finally 591 | DNS.Free; 592 | t.Free; 593 | end; 594 | end; 595 | 596 | end. 597 | -------------------------------------------------------------------------------- /synapse/ftptsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.000 | 3 | |==============================================================================| 4 | | Content: Trivial FTP (TFTP) client and server | 5 | |==============================================================================| 6 | | Copyright (c)1999-2004, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2003-2004. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {: @abstract(TFTP client and server protocol) 46 | 47 | Used RFC: RFC-1350 48 | } 49 | 50 | {$IFDEF FPC} 51 | {$MODE DELPHI} 52 | {$ENDIF} 53 | {$Q-} 54 | {$H+} 55 | 56 | unit ftptsend; 57 | 58 | interface 59 | 60 | uses 61 | SysUtils, Classes, 62 | blcksock, synautil; 63 | 64 | const 65 | cTFTPProtocol = '69'; 66 | 67 | cTFTP_RRQ = word(1); 68 | cTFTP_WRQ = word(2); 69 | cTFTP_DTA = word(3); 70 | cTFTP_ACK = word(4); 71 | cTFTP_ERR = word(5); 72 | 73 | type 74 | {:@abstract(Implementation of TFTP client and server) 75 | Note: Are you missing properties for specify server address and port? Look to 76 | parent @link(TSynaClient) too!} 77 | TTFTPSend = class(TSynaClient) 78 | private 79 | FSock: TUDPBlockSocket; 80 | FErrorCode: integer; 81 | FErrorString: string; 82 | FData: TMemoryStream; 83 | FRequestIP: string; 84 | FRequestPort: string; 85 | function SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; 86 | function RecvPacket(Serial: word; var Value: string): Boolean; 87 | public 88 | constructor Create; 89 | destructor Destroy; override; 90 | 91 | {:Upload @link(data) as file to TFTP server.} 92 | function SendFile(const Filename: string): Boolean; 93 | 94 | {:Download file from TFTP server to @link(data).} 95 | function RecvFile(const Filename: string): Boolean; 96 | 97 | {:Acts as TFTP server and wait for client request. When some request 98 | incoming within Timeout, result is @true and parametres is filled with 99 | information from request. You must handle this request, validate it, and 100 | call @link(ReplyError), @link(ReplyRecv) or @link(ReplySend) for send reply 101 | to TFTP Client.} 102 | function WaitForRequest(var Req: word; var filename: string): Boolean; 103 | 104 | {:send error to TFTP client, when you acts as TFTP server.} 105 | procedure ReplyError(Error: word; Description: string); 106 | 107 | {:Accept uploaded file from TFTP client to @link(data), when you acts as 108 | TFTP server.} 109 | function ReplyRecv: Boolean; 110 | 111 | {:Accept download request file from TFTP client and send content of 112 | @link(data), when you acts as TFTP server.} 113 | function ReplySend: Boolean; 114 | published 115 | {:Code of TFTP error.} 116 | property ErrorCode: integer read FErrorCode; 117 | 118 | {:Human readable decription of TFTP error. (if is sended by remote side)} 119 | property ErrorString: string read FErrorString; 120 | 121 | {:MemoryStream with datas for sending or receiving} 122 | property Data: TMemoryStream read FData; 123 | 124 | {:Address of TFTP remote side.} 125 | property RequestIP: string read FRequestIP write FRequestIP; 126 | 127 | {:Port of TFTP remote side.} 128 | property RequestPort: string read FRequestPort write FRequestPort; 129 | end; 130 | 131 | implementation 132 | 133 | constructor TTFTPSend.Create; 134 | begin 135 | inherited Create; 136 | FSock := TUDPBlockSocket.Create; 137 | FTargetPort := cTFTPProtocol; 138 | FData := TMemoryStream.Create; 139 | FErrorCode := 0; 140 | FErrorString := ''; 141 | end; 142 | 143 | destructor TTFTPSend.Destroy; 144 | begin 145 | FSock.Free; 146 | FData.Free; 147 | inherited Destroy; 148 | end; 149 | 150 | function TTFTPSend.SendPacket(Cmd: word; Serial: word; const Value: string): Boolean; 151 | var 152 | s, sh: string; 153 | begin 154 | FErrorCode := 0; 155 | FErrorString := ''; 156 | Result := false; 157 | if Cmd <> 2 then 158 | s := CodeInt(Cmd) + CodeInt(Serial) + Value 159 | else 160 | s := CodeInt(Cmd) + Value; 161 | FSock.SendString(s); 162 | s := FSock.RecvPacket(FTimeout); 163 | if FSock.LastError = 0 then 164 | if length(s) >= 4 then 165 | begin 166 | sh := CodeInt(4) + CodeInt(Serial); 167 | if Pos(sh, s) = 1 then 168 | Result := True 169 | else 170 | if s[1] = #5 then 171 | begin 172 | FErrorCode := DecodeInt(s, 3); 173 | Delete(s, 1, 4); 174 | FErrorString := SeparateLeft(s, #0); 175 | end; 176 | end; 177 | end; 178 | 179 | function TTFTPSend.RecvPacket(Serial: word; var Value: string): Boolean; 180 | var 181 | s: string; 182 | ser: word; 183 | begin 184 | FErrorCode := 0; 185 | FErrorString := ''; 186 | Result := False; 187 | Value := ''; 188 | s := FSock.RecvPacket(FTimeout); 189 | if FSock.LastError = 0 then 190 | if length(s) >= 4 then 191 | if DecodeInt(s, 1) = 3 then 192 | begin 193 | ser := DecodeInt(s, 3); 194 | if ser = Serial then 195 | begin 196 | Delete(s, 1, 4); 197 | Value := s; 198 | S := CodeInt(4) + CodeInt(ser); 199 | FSock.SendString(s); 200 | Result := FSock.LastError = 0; 201 | end 202 | else 203 | begin 204 | S := CodeInt(5) + CodeInt(5) + 'Unexcepted serial#' + #0; 205 | FSock.SendString(s); 206 | end; 207 | end; 208 | if DecodeInt(s, 1) = 5 then 209 | begin 210 | FErrorCode := DecodeInt(s, 3); 211 | Delete(s, 1, 4); 212 | FErrorString := SeparateLeft(s, #0); 213 | end; 214 | end; 215 | 216 | function TTFTPSend.SendFile(const Filename: string): Boolean; 217 | var 218 | s: string; 219 | ser: word; 220 | n, n1, n2: integer; 221 | begin 222 | Result := False; 223 | FErrorCode := 0; 224 | FErrorString := ''; 225 | FSock.CloseSocket; 226 | FSock.Connect(FTargetHost, FTargetPort); 227 | try 228 | if FSock.LastError = 0 then 229 | begin 230 | s := Filename + #0 + 'octet' + #0; 231 | if not Sendpacket(2, 0, s) then 232 | Exit; 233 | ser := 1; 234 | FData.Position := 0; 235 | n1 := FData.Size div 512; 236 | n2 := FData.Size mod 512; 237 | for n := 1 to n1 do 238 | begin 239 | s := ReadStrFromStream(FData, 512); 240 | // SetLength(s, 512); 241 | // FData.Read(pointer(s)^, 512); 242 | if not Sendpacket(3, ser, s) then 243 | Exit; 244 | inc(ser); 245 | end; 246 | s := ReadStrFromStream(FData, n2); 247 | // SetLength(s, n2); 248 | // FData.Read(pointer(s)^, n2); 249 | if not Sendpacket(3, ser, s) then 250 | Exit; 251 | Result := True; 252 | end; 253 | finally 254 | FSock.CloseSocket; 255 | end; 256 | end; 257 | 258 | function TTFTPSend.RecvFile(const Filename: string): Boolean; 259 | var 260 | s: string; 261 | ser: word; 262 | begin 263 | Result := False; 264 | FErrorCode := 0; 265 | FErrorString := ''; 266 | FSock.CloseSocket; 267 | FSock.Connect(FTargetHost, FTargetPort); 268 | try 269 | if FSock.LastError = 0 then 270 | begin 271 | s := CodeInt(1) + Filename + #0 + 'octet' + #0; 272 | FSock.SendString(s); 273 | if FSock.LastError <> 0 then 274 | Exit; 275 | FData.Clear; 276 | ser := 1; 277 | repeat 278 | if not RecvPacket(ser, s) then 279 | Exit; 280 | inc(ser); 281 | WriteStrToStream(FData, s); 282 | // FData.Write(pointer(s)^, length(s)); 283 | until length(s) <> 512; 284 | FData.Position := 0; 285 | Result := true; 286 | end; 287 | finally 288 | FSock.CloseSocket; 289 | end; 290 | end; 291 | 292 | function TTFTPSend.WaitForRequest(var Req: word; var filename: string): Boolean; 293 | var 294 | s: string; 295 | begin 296 | Result := False; 297 | FErrorCode := 0; 298 | FErrorString := ''; 299 | FSock.CloseSocket; 300 | FSock.Bind('0.0.0.0', FTargetPort); 301 | if FSock.LastError = 0 then 302 | begin 303 | s := FSock.RecvPacket(FTimeout); 304 | if FSock.LastError = 0 then 305 | if Length(s) >= 4 then 306 | begin 307 | FRequestIP := FSock.GetRemoteSinIP; 308 | FRequestPort := IntToStr(FSock.GetRemoteSinPort); 309 | Req := DecodeInt(s, 1); 310 | delete(s, 1, 2); 311 | filename := Trim(SeparateLeft(s, #0)); 312 | s := SeparateRight(s, #0); 313 | s := SeparateLeft(s, #0); 314 | Result := lowercase(trim(s)) = 'octet'; 315 | end; 316 | end; 317 | end; 318 | 319 | procedure TTFTPSend.ReplyError(Error: word; Description: string); 320 | var 321 | s: string; 322 | begin 323 | FSock.CloseSocket; 324 | FSock.Connect(FRequestIP, FRequestPort); 325 | s := CodeInt(5) + CodeInt(Error) + Description + #0; 326 | FSock.SendString(s); 327 | FSock.CloseSocket; 328 | end; 329 | 330 | function TTFTPSend.ReplyRecv: Boolean; 331 | var 332 | s: string; 333 | ser: integer; 334 | begin 335 | Result := False; 336 | FErrorCode := 0; 337 | FErrorString := ''; 338 | FSock.CloseSocket; 339 | FSock.Connect(FRequestIP, FRequestPort); 340 | try 341 | s := CodeInt(4) + CodeInt(0); 342 | FSock.SendString(s); 343 | FData.Clear; 344 | ser := 1; 345 | repeat 346 | if not RecvPacket(ser, s) then 347 | Exit; 348 | inc(ser); 349 | WriteStrToStream(FData, s); 350 | // FData.Write(pointer(s)^, length(s)); 351 | until length(s) <> 512; 352 | FData.Position := 0; 353 | Result := true; 354 | finally 355 | FSock.CloseSocket; 356 | end; 357 | end; 358 | 359 | function TTFTPSend.ReplySend: Boolean; 360 | var 361 | s: string; 362 | ser: word; 363 | n, n1, n2: integer; 364 | begin 365 | Result := False; 366 | FErrorCode := 0; 367 | FErrorString := ''; 368 | FSock.CloseSocket; 369 | FSock.Connect(FRequestIP, FRequestPort); 370 | try 371 | ser := 1; 372 | FData.Position := 0; 373 | n1 := FData.Size div 512; 374 | n2 := FData.Size mod 512; 375 | for n := 1 to n1 do 376 | begin 377 | s := ReadStrFromStream(FData, 512); 378 | // SetLength(s, 512); 379 | // FData.Read(pointer(s)^, 512); 380 | if not Sendpacket(3, ser, s) then 381 | Exit; 382 | inc(ser); 383 | end; 384 | s := ReadStrFromStream(FData, n2); 385 | // SetLength(s, n2); 386 | // FData.Read(pointer(s)^, n2); 387 | if not Sendpacket(3, ser, s) then 388 | Exit; 389 | Result := True; 390 | finally 391 | FSock.CloseSocket; 392 | end; 393 | end; 394 | 395 | {==============================================================================} 396 | 397 | end. 398 | -------------------------------------------------------------------------------- /synapse/mimeinln.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.011 | 3 | |==============================================================================| 4 | | Content: Inline MIME support procedures and functions | 5 | |==============================================================================| 6 | | Copyright (c)1999-2006, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2000-2006. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract(Utilities for inline MIME) 46 | Support for Inline MIME encoding and decoding. 47 | 48 | Used RFC: RFC-2047, RFC-2231 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$H+} 55 | 56 | unit mimeinln; 57 | 58 | interface 59 | 60 | uses 61 | SysUtils, Classes, 62 | synachar, synacode, synautil; 63 | 64 | {:Decodes mime inline encoding (i.e. in headers) uses target characterset "CP".} 65 | function InlineDecode(const Value: string; CP: TMimeChar): string; 66 | 67 | {:Encodes string to MIME inline encoding. The source characterset is "CP", and 68 | the target charset is "MimeP".} 69 | function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; 70 | 71 | {:Returns @true, if "Value" contains characters needed for inline coding.} 72 | function NeedInline(const Value: AnsiString): boolean; 73 | 74 | {:Inline mime encoding similar to @link(InlineEncode), but you can specify 75 | source charset, and the target characterset is automatically assigned.} 76 | function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; 77 | 78 | {:Inline MIME encoding similar to @link(InlineEncode), but the source charset 79 | is automatically set to the system default charset, and the target charset is 80 | automatically assigned from set of allowed encoding for MIME.} 81 | function InlineCode(const Value: string): string; 82 | 83 | {:Converts e-mail address to canonical mime form. You can specify source charset.} 84 | function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; 85 | 86 | {:Converts e-mail address to canonical mime form. Source charser it system 87 | default charset.} 88 | function InlineEmail(const Value: string): string; 89 | 90 | implementation 91 | 92 | {==============================================================================} 93 | 94 | function InlineDecode(const Value: string; CP: TMimeChar): string; 95 | var 96 | s, su, v: string; 97 | x, y, z, n: Integer; 98 | ichar: TMimeChar; 99 | c: Char; 100 | 101 | function SearchEndInline(const Value: string; be: Integer): Integer; 102 | var 103 | n, q: Integer; 104 | begin 105 | q := 0; 106 | Result := 0; 107 | for n := be + 2 to Length(Value) - 1 do 108 | if Value[n] = '?' then 109 | begin 110 | Inc(q); 111 | if (q > 2) and (Value[n + 1] = '=') then 112 | begin 113 | Result := n; 114 | Break; 115 | end; 116 | end; 117 | end; 118 | 119 | begin 120 | Result := ''; 121 | v := Value; 122 | x := Pos('=?', v); 123 | y := SearchEndInline(v, x); 124 | //fix for broken coding with begin, but not with end. 125 | if (x > 0) and (y <= 0) then 126 | y := Length(Result); 127 | while (y > x) and (x > 0) do 128 | begin 129 | s := Copy(v, 1, x - 1); 130 | if Trim(s) <> '' then 131 | Result := Result + s; 132 | s := Copy(v, x, y - x + 2); 133 | Delete(v, 1, y + 1); 134 | su := Copy(s, 3, Length(s) - 4); 135 | z := Pos('?', su); 136 | if (Length(su) >= (z + 2)) and (su[z + 2] = '?') then 137 | begin 138 | ichar := GetCPFromID(SeparateLeft(Copy(su, 1, z - 1), '*')); 139 | c := UpperCase(su)[z + 1]; 140 | su := Copy(su, z + 3, Length(su) - z - 2); 141 | if c = 'B' then 142 | begin 143 | s := DecodeBase64(su); 144 | s := CharsetConversion(s, ichar, CP); 145 | end; 146 | if c = 'Q' then 147 | begin 148 | s := ''; 149 | for n := 1 to Length(su) do 150 | if su[n] = '_' then 151 | s := s + ' ' 152 | else 153 | s := s + su[n]; 154 | s := DecodeQuotedPrintable(s); 155 | s := CharsetConversion(s, ichar, CP); 156 | end; 157 | end; 158 | Result := Result + s; 159 | x := Pos('=?', v); 160 | y := SearchEndInline(v, x); 161 | end; 162 | Result := Result + v; 163 | end; 164 | 165 | {==============================================================================} 166 | 167 | function InlineEncode(const Value: string; CP, MimeP: TMimeChar): string; 168 | var 169 | s, s1, e: string; 170 | n: Integer; 171 | begin 172 | s := CharsetConversion(Value, CP, MimeP); 173 | s := EncodeSafeQuotedPrintable(s); 174 | e := GetIdFromCP(MimeP); 175 | s1 := ''; 176 | Result := ''; 177 | for n := 1 to Length(s) do 178 | if s[n] = ' ' then 179 | begin 180 | // s1 := s1 + '=20'; 181 | s1 := s1 + '_'; 182 | if Length(s1) > 32 then 183 | begin 184 | if Result <> '' then 185 | Result := Result + ' '; 186 | Result := Result + '=?' + e + '?Q?' + s1 + '?='; 187 | s1 := ''; 188 | end; 189 | end 190 | else 191 | s1 := s1 + s[n]; 192 | if s1 <> '' then 193 | begin 194 | if Result <> '' then 195 | Result := Result + ' '; 196 | Result := Result + '=?' + e + '?Q?' + s1 + '?='; 197 | end; 198 | end; 199 | 200 | {==============================================================================} 201 | 202 | function NeedInline(const Value: AnsiString): boolean; 203 | var 204 | n: Integer; 205 | begin 206 | Result := False; 207 | for n := 1 to Length(Value) do 208 | if Value[n] in (SpecialChar + NonAsciiChar - ['_']) then 209 | begin 210 | Result := True; 211 | Break; 212 | end; 213 | end; 214 | 215 | {==============================================================================} 216 | 217 | function InlineCodeEx(const Value: string; FromCP: TMimeChar): string; 218 | var 219 | c: TMimeChar; 220 | begin 221 | if NeedInline(Value) then 222 | begin 223 | c := IdealCharsetCoding(Value, FromCP, IdealCharsets); 224 | Result := InlineEncode(Value, FromCP, c); 225 | end 226 | else 227 | Result := Value; 228 | end; 229 | 230 | {==============================================================================} 231 | 232 | function InlineCode(const Value: string): string; 233 | begin 234 | Result := InlineCodeEx(Value, GetCurCP); 235 | end; 236 | 237 | {==============================================================================} 238 | 239 | function InlineEmailEx(const Value: string; FromCP: TMimeChar): string; 240 | var 241 | sd, se: string; 242 | begin 243 | sd := GetEmailDesc(Value); 244 | se := GetEmailAddr(Value); 245 | if sd = '' then 246 | Result := se 247 | else 248 | Result := '"' + InlineCodeEx(sd, FromCP) + '" <' + se + '>'; 249 | end; 250 | 251 | {==============================================================================} 252 | 253 | function InlineEmail(const Value: string): string; 254 | begin 255 | Result := InlineEmailEx(Value, GetCurCP); 256 | end; 257 | 258 | end. 259 | -------------------------------------------------------------------------------- /synapse/nntpsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.005.001 | 3 | |==============================================================================| 4 | | Content: NNTP client | 5 | |==============================================================================| 6 | | Copyright (c)1999-2007, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c) 1999-2007. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract(NNTP client) 46 | NNTP (network news transfer protocol) 47 | 48 | Used RFC: RFC-977, RFC-2980 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$H+} 55 | 56 | unit nntpsend; 57 | 58 | interface 59 | 60 | uses 61 | SysUtils, Classes, 62 | blcksock, synautil; 63 | 64 | const 65 | cNNTPProtocol = '119'; 66 | 67 | type 68 | 69 | {:abstract(Implementation of Network News Transfer Protocol. 70 | 71 | Note: Are you missing properties for setting Username and Password? Look to 72 | parent @link(TSynaClient) object! 73 | 74 | Are you missing properties for specify server address and port? Look to 75 | parent @link(TSynaClient) too!} 76 | TNNTPSend = class(TSynaClient) 77 | private 78 | FSock: TTCPBlockSocket; 79 | FResultCode: Integer; 80 | FResultString: string; 81 | FData: TStringList; 82 | FDataToSend: TStringList; 83 | FAutoTLS: Boolean; 84 | FFullSSL: Boolean; 85 | FNNTPcap: TStringList; 86 | function ReadResult: Integer; 87 | function ReadData: boolean; 88 | function SendData: boolean; 89 | function Connect: Boolean; 90 | public 91 | constructor Create; 92 | destructor Destroy; override; 93 | 94 | {:Connects to NNTP server and begin session.} 95 | function Login: Boolean; 96 | 97 | {:Logout from NNTP server and terminate session.} 98 | function Logout: Boolean; 99 | 100 | {:By this you can call any NNTP command.} 101 | function DoCommand(const Command: string): boolean; 102 | 103 | {:by this you can call any NNTP command. This variant is used for commands 104 | for download information from server.} 105 | function DoCommandRead(const Command: string): boolean; 106 | 107 | {:by this you can call any NNTP command. This variant is used for commands 108 | for upload information to server.} 109 | function DoCommandWrite(const Command: string): boolean; 110 | 111 | {:Download full message to @link(data) property. Value can be number of 112 | message or message-id (in brackets).} 113 | function GetArticle(const Value: string): Boolean; 114 | 115 | {:Download only body of message to @link(data) property. Value can be number 116 | of message or message-id (in brackets).} 117 | function GetBody(const Value: string): Boolean; 118 | 119 | {:Download only headers of message to @link(data) property. Value can be 120 | number of message or message-id (in brackets).} 121 | function GetHead(const Value: string): Boolean; 122 | 123 | {:Get message status. Value can be number of message or message-id 124 | (in brackets).} 125 | function GetStat(const Value: string): Boolean; 126 | 127 | {:Select given group.} 128 | function SelectGroup(const Value: string): Boolean; 129 | 130 | {:Tell to server 'I have mesage with given message-ID.' If server need this 131 | message, message is uploaded to server.} 132 | function IHave(const MessID: string): Boolean; 133 | 134 | {:Move message pointer to last item in group.} 135 | function GotoLast: Boolean; 136 | 137 | {:Move message pointer to next item in group.} 138 | function GotoNext: Boolean; 139 | 140 | {:Download to @link(data) property list of all groups on NNTP server.} 141 | function ListGroups: Boolean; 142 | 143 | {:Download to @link(data) property list of all groups created after given time.} 144 | function ListNewGroups(Since: TDateTime): Boolean; 145 | 146 | {:Download to @link(data) property list of message-ids in given group since 147 | given time.} 148 | function NewArticles(const Group: string; Since: TDateTime): Boolean; 149 | 150 | {:Upload new article to server. (for new messages by you)} 151 | function PostArticle: Boolean; 152 | 153 | {:Tells to remote NNTP server 'I am not NNTP client, but I am another NNTP 154 | server'.} 155 | function SwitchToSlave: Boolean; 156 | 157 | {:Call NNTP XOVER command.} 158 | function Xover(xoStart, xoEnd: string): boolean; 159 | 160 | {:Call STARTTLS command for upgrade connection to SSL/TLS mode.} 161 | function StartTLS: Boolean; 162 | 163 | {:Try to find given capability in extension list. This list is getted after 164 | successful login to NNTP server. If extension capability is not found, 165 | then return is empty string.} 166 | function FindCap(const Value: string): string; 167 | 168 | {:Try get list of server extensions. List is returned in @link(data) property.} 169 | function ListExtensions: Boolean; 170 | published 171 | {:Result code number of last operation.} 172 | property ResultCode: Integer read FResultCode; 173 | 174 | {:String description of last result code from NNTP server.} 175 | property ResultString: string read FResultString; 176 | 177 | {:Readed data. (message, etc.)} 178 | property Data: TStringList read FData; 179 | 180 | {:If is set to @true, then upgrade to SSL/TLS mode after login if remote 181 | server support it.} 182 | property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; 183 | 184 | {:SSL/TLS mode is used from first contact to server. Servers with full 185 | SSL/TLS mode usualy using non-standard TCP port!} 186 | property FullSSL: Boolean read FFullSSL Write FFullSSL; 187 | 188 | {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} 189 | property Sock: TTCPBlockSocket read FSock; 190 | end; 191 | 192 | implementation 193 | 194 | constructor TNNTPSend.Create; 195 | begin 196 | inherited Create; 197 | FSock := TTCPBlockSocket.Create; 198 | FData := TStringList.Create; 199 | FDataToSend := TStringList.Create; 200 | FNNTPcap := TStringList.Create; 201 | FSock.ConvertLineEnd := True; 202 | FTimeout := 60000; 203 | FTargetPort := cNNTPProtocol; 204 | FAutoTLS := False; 205 | FFullSSL := False; 206 | end; 207 | 208 | destructor TNNTPSend.Destroy; 209 | begin 210 | FSock.Free; 211 | FDataToSend.Free; 212 | FData.Free; 213 | FNNTPcap.Free; 214 | inherited Destroy; 215 | end; 216 | 217 | function TNNTPSend.ReadResult: Integer; 218 | var 219 | s: string; 220 | begin 221 | Result := 0; 222 | FData.Clear; 223 | s := FSock.RecvString(FTimeout); 224 | FResultString := Copy(s, 5, Length(s) - 4); 225 | if FSock.LastError <> 0 then 226 | Exit; 227 | if Length(s) >= 3 then 228 | Result := StrToIntDef(Copy(s, 1, 3), 0); 229 | FResultCode := Result; 230 | end; 231 | 232 | function TNNTPSend.ReadData: boolean; 233 | var 234 | s: string; 235 | begin 236 | repeat 237 | s := FSock.RecvString(FTimeout); 238 | if s = '.' then 239 | break; 240 | if (s <> '') and (s[1] = '.') then 241 | s := Copy(s, 2, Length(s) - 1); 242 | FData.Add(s); 243 | until FSock.LastError <> 0; 244 | Result := FSock.LastError = 0; 245 | end; 246 | 247 | function TNNTPSend.SendData: boolean; 248 | var 249 | s: string; 250 | n: integer; 251 | begin 252 | for n := 0 to FDataToSend.Count - 1 do 253 | begin 254 | s := FDataToSend[n]; 255 | if (s <> '') and (s[1] = '.') then 256 | s := s + '.'; 257 | FSock.SendString(s + CRLF); 258 | if FSock.LastError <> 0 then 259 | break; 260 | end; 261 | if FDataToSend.Count = 0 then 262 | FSock.SendString(CRLF); 263 | if FSock.LastError = 0 then 264 | FSock.SendString('.' + CRLF); 265 | FDataToSend.Clear; 266 | Result := FSock.LastError = 0; 267 | end; 268 | 269 | function TNNTPSend.Connect: Boolean; 270 | begin 271 | FSock.CloseSocket; 272 | FSock.Bind(FIPInterface, cAnyPort); 273 | if FSock.LastError = 0 then 274 | FSock.Connect(FTargetHost, FTargetPort); 275 | if FSock.LastError = 0 then 276 | if FFullSSL then 277 | FSock.SSLDoConnect; 278 | Result := FSock.LastError = 0; 279 | end; 280 | 281 | function TNNTPSend.Login: Boolean; 282 | begin 283 | Result := False; 284 | FNNTPcap.Clear; 285 | if not Connect then 286 | Exit; 287 | Result := (ReadResult div 100) = 2; 288 | ListExtensions; 289 | FNNTPcap.Assign(Fdata); 290 | if Result then 291 | if (not FullSSL) and FAutoTLS and (FindCap('STARTTLS') <> '') then 292 | Result := StartTLS; 293 | if (FUsername <> '') and Result then 294 | begin 295 | FSock.SendString('AUTHINFO USER ' + FUsername + CRLF); 296 | if (ReadResult div 100) = 3 then 297 | begin 298 | FSock.SendString('AUTHINFO PASS ' + FPassword + CRLF); 299 | Result := (ReadResult div 100) = 2; 300 | end; 301 | end; 302 | end; 303 | 304 | function TNNTPSend.Logout: Boolean; 305 | begin 306 | FSock.SendString('QUIT' + CRLF); 307 | Result := (ReadResult div 100) = 2; 308 | FSock.CloseSocket; 309 | end; 310 | 311 | function TNNTPSend.DoCommand(const Command: string): Boolean; 312 | begin 313 | FSock.SendString(Command + CRLF); 314 | Result := (ReadResult div 100) = 2; 315 | Result := Result and (FSock.LastError = 0); 316 | end; 317 | 318 | function TNNTPSend.DoCommandRead(const Command: string): Boolean; 319 | begin 320 | Result := DoCommand(Command); 321 | if Result then 322 | begin 323 | Result := ReadData; 324 | Result := Result and (FSock.LastError = 0); 325 | end; 326 | end; 327 | 328 | function TNNTPSend.DoCommandWrite(const Command: string): Boolean; 329 | var 330 | x: integer; 331 | begin 332 | FDataToSend.Assign(FData); 333 | FSock.SendString(Command + CRLF); 334 | x := (ReadResult div 100); 335 | if x = 3 then 336 | begin 337 | SendData; 338 | x := (ReadResult div 100); 339 | end; 340 | Result := x = 2; 341 | Result := Result and (FSock.LastError = 0); 342 | end; 343 | 344 | function TNNTPSend.GetArticle(const Value: string): Boolean; 345 | var 346 | s: string; 347 | begin 348 | s := 'ARTICLE'; 349 | if Value <> '' then 350 | s := s + ' ' + Value; 351 | Result := DoCommandRead(s); 352 | end; 353 | 354 | function TNNTPSend.GetBody(const Value: string): Boolean; 355 | var 356 | s: string; 357 | begin 358 | s := 'BODY'; 359 | if Value <> '' then 360 | s := s + ' ' + Value; 361 | Result := DoCommandRead(s); 362 | end; 363 | 364 | function TNNTPSend.GetHead(const Value: string): Boolean; 365 | var 366 | s: string; 367 | begin 368 | s := 'HEAD'; 369 | if Value <> '' then 370 | s := s + ' ' + Value; 371 | Result := DoCommandRead(s); 372 | end; 373 | 374 | function TNNTPSend.GetStat(const Value: string): Boolean; 375 | var 376 | s: string; 377 | begin 378 | s := 'STAT'; 379 | if Value <> '' then 380 | s := s + ' ' + Value; 381 | Result := DoCommand(s); 382 | end; 383 | 384 | function TNNTPSend.SelectGroup(const Value: string): Boolean; 385 | begin 386 | Result := DoCommand('GROUP ' + Value); 387 | end; 388 | 389 | function TNNTPSend.IHave(const MessID: string): Boolean; 390 | begin 391 | Result := DoCommandWrite('IHAVE ' + MessID); 392 | end; 393 | 394 | function TNNTPSend.GotoLast: Boolean; 395 | begin 396 | Result := DoCommand('LAST'); 397 | end; 398 | 399 | function TNNTPSend.GotoNext: Boolean; 400 | begin 401 | Result := DoCommand('NEXT'); 402 | end; 403 | 404 | function TNNTPSend.ListGroups: Boolean; 405 | begin 406 | Result := DoCommandRead('LIST'); 407 | end; 408 | 409 | function TNNTPSend.ListNewGroups(Since: TDateTime): Boolean; 410 | begin 411 | Result := DoCommandRead('NEWGROUPS ' + SimpleDateTime(Since) + ' GMT'); 412 | end; 413 | 414 | function TNNTPSend.NewArticles(const Group: string; Since: TDateTime): Boolean; 415 | begin 416 | Result := DoCommandRead('NEWNEWS ' + Group + ' ' + SimpleDateTime(Since) + ' GMT'); 417 | end; 418 | 419 | function TNNTPSend.PostArticle: Boolean; 420 | begin 421 | Result := DoCommandWrite('POST'); 422 | end; 423 | 424 | function TNNTPSend.SwitchToSlave: Boolean; 425 | begin 426 | Result := DoCommand('SLAVE'); 427 | end; 428 | 429 | function TNNTPSend.Xover(xoStart, xoEnd: string): Boolean; 430 | var 431 | s: string; 432 | begin 433 | s := 'XOVER ' + xoStart; 434 | if xoEnd <> xoStart then 435 | s := s + '-' + xoEnd; 436 | Result := DoCommandRead(s); 437 | end; 438 | 439 | function TNNTPSend.StartTLS: Boolean; 440 | begin 441 | Result := False; 442 | if FindCap('STARTTLS') <> '' then 443 | begin 444 | if DoCommand('STARTTLS') then 445 | begin 446 | Fsock.SSLDoConnect; 447 | Result := FSock.LastError = 0; 448 | end; 449 | end; 450 | end; 451 | 452 | function TNNTPSend.ListExtensions: Boolean; 453 | begin 454 | Result := DoCommandRead('LIST EXTENSIONS'); 455 | end; 456 | 457 | function TNNTPSend.FindCap(const Value: string): string; 458 | var 459 | n: Integer; 460 | s: string; 461 | begin 462 | s := UpperCase(Value); 463 | Result := ''; 464 | for n := 0 to FNNTPcap.Count - 1 do 465 | if Pos(s, UpperCase(FNNTPcap[n])) = 1 then 466 | begin 467 | Result := FNNTPcap[n]; 468 | Break; 469 | end; 470 | end; 471 | 472 | {==============================================================================} 473 | 474 | end. 475 | -------------------------------------------------------------------------------- /synapse/pop3send.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 002.006.000 | 3 | |==============================================================================| 4 | | Content: POP3 client | 5 | |==============================================================================| 6 | | Copyright (c)1999-2007, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2001-2007. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract(POP3 protocol client) 46 | 47 | Used RFC: RFC-1734, RFC-1939, RFC-2195, RFC-2449, RFC-2595 48 | } 49 | 50 | {$IFDEF FPC} 51 | {$MODE DELPHI} 52 | {$ENDIF} 53 | {$H+} 54 | 55 | unit pop3send; 56 | 57 | interface 58 | 59 | uses 60 | SysUtils, Classes, 61 | blcksock, synautil, synacode; 62 | 63 | const 64 | cPop3Protocol = '110'; 65 | 66 | type 67 | 68 | {:The three types of possible authorization methods for "logging in" to a POP3 69 | server.} 70 | TPOP3AuthType = (POP3AuthAll, POP3AuthLogin, POP3AuthAPOP); 71 | 72 | {:@abstract(Implementation of POP3 client protocol.) 73 | 74 | Note: Are you missing properties for setting Username and Password? Look to 75 | parent @link(TSynaClient) object! 76 | 77 | Are you missing properties for specify server address and port? Look to 78 | parent @link(TSynaClient) too!} 79 | TPOP3Send = class(TSynaClient) 80 | private 81 | FSock: TTCPBlockSocket; 82 | FResultCode: Integer; 83 | FResultString: string; 84 | FFullResult: TStringList; 85 | FStatCount: Integer; 86 | FStatSize: Integer; 87 | FListSize: Integer; 88 | FTimeStamp: string; 89 | FAuthType: TPOP3AuthType; 90 | FPOP3cap: TStringList; 91 | FAutoTLS: Boolean; 92 | FFullSSL: Boolean; 93 | function ReadResult(Full: Boolean): Integer; 94 | function Connect: Boolean; 95 | function AuthLogin: Boolean; 96 | function AuthApop: Boolean; 97 | public 98 | constructor Create; 99 | destructor Destroy; override; 100 | 101 | {:You can call any custom by this method. Call Command without trailing CRLF. 102 | If MultiLine parameter is @true, multilined response are expected. 103 | Result is @true on sucess.} 104 | function CustomCommand(const Command: string; MultiLine: Boolean): boolean; 105 | 106 | {:Call CAPA command for get POP3 server capabilites. 107 | note: not all servers support this command!} 108 | function Capability: Boolean; 109 | 110 | {:Connect to remote POP3 host. If all OK, result is @true.} 111 | function Login: Boolean; 112 | 113 | {:Disconnects from POP3 server.} 114 | function Logout: Boolean; 115 | 116 | {:Send RSET command. If all OK, result is @true.} 117 | function Reset: Boolean; 118 | 119 | {:Send NOOP command. If all OK, result is @true.} 120 | function NoOp: Boolean; 121 | 122 | {:Send STAT command and fill @link(StatCount) and @link(StatSize) property. 123 | If all OK, result is @true.} 124 | function Stat: Boolean; 125 | 126 | {:Send LIST command. If Value is 0, LIST is for all messages. After 127 | successful operation is listing in FullResult. If all OK, result is @True.} 128 | function List(Value: Integer): Boolean; 129 | 130 | {:Send RETR command. After successful operation dowloaded message in 131 | @link(FullResult). If all OK, result is @true.} 132 | function Retr(Value: Integer): Boolean; 133 | 134 | {:Send RETR command. After successful operation dowloaded message in 135 | @link(Stream). If all OK, result is @true.} 136 | function RetrStream(Value: Integer; Stream: TStream): Boolean; 137 | 138 | {:Send DELE command for delete specified message. If all OK, result is @true.} 139 | function Dele(Value: Integer): Boolean; 140 | 141 | {:Send TOP command. After successful operation dowloaded headers of message 142 | and maxlines count of message in @link(FullResult). If all OK, result is 143 | @true.} 144 | function Top(Value, Maxlines: Integer): Boolean; 145 | 146 | {:Send UIDL command. If Value is 0, UIDL is for all messages. After 147 | successful operation is listing in FullResult. If all OK, result is @True.} 148 | function Uidl(Value: Integer): Boolean; 149 | 150 | {:Call STLS command for upgrade connection to SSL/TLS mode.} 151 | function StartTLS: Boolean; 152 | 153 | {:Try to find given capabily in capabilty string returned from POP3 server 154 | by CAPA command.} 155 | function FindCap(const Value: string): string; 156 | published 157 | {:Result code of last POP3 operation. 0 - error, 1 - OK.} 158 | property ResultCode: Integer read FResultCode; 159 | 160 | {:Result string of last POP3 operation.} 161 | property ResultString: string read FResultString; 162 | 163 | {:Stringlist with full lines returned as result of POP3 operation. I.e. if 164 | operation is LIST, this property is filled by list of messages. If 165 | operation is RETR, this property have downloaded message.} 166 | property FullResult: TStringList read FFullResult; 167 | 168 | {:After STAT command is there count of messages in inbox.} 169 | property StatCount: Integer read FStatCount; 170 | 171 | {:After STAT command is there size of all messages in inbox.} 172 | property StatSize: Integer read FStatSize; 173 | 174 | {:After LIST 0 command size of all messages on server, After LIST x size of message x on server} 175 | property ListSize: Integer read FListSize; 176 | 177 | {:If server support this, after comnnect is in this property timestamp of 178 | remote server.} 179 | property TimeStamp: string read FTimeStamp; 180 | 181 | {:Type of authorisation for login to POP3 server. Dafault is autodetect one 182 | of possible authorisation. Autodetect do this: 183 | 184 | If remote POP3 server support APOP, try login by APOP method. If APOP is 185 | not supported, or if APOP login failed, try classic USER+PASS login method.} 186 | property AuthType: TPOP3AuthType read FAuthType Write FAuthType; 187 | 188 | {:If is set to @true, then upgrade to SSL/TLS mode if remote server support it.} 189 | property AutoTLS: Boolean read FAutoTLS Write FAutoTLS; 190 | 191 | {:SSL/TLS mode is used from first contact to server. Servers with full 192 | SSL/TLS mode usualy using non-standard TCP port!} 193 | property FullSSL: Boolean read FFullSSL Write FFullSSL; 194 | {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} 195 | property Sock: TTCPBlockSocket read FSock; 196 | end; 197 | 198 | implementation 199 | 200 | constructor TPOP3Send.Create; 201 | begin 202 | inherited Create; 203 | FFullResult := TStringList.Create; 204 | FPOP3cap := TStringList.Create; 205 | FSock := TTCPBlockSocket.Create; 206 | FSock.ConvertLineEnd := true; 207 | FTimeout := 60000; 208 | FTargetPort := cPop3Protocol; 209 | FStatCount := 0; 210 | FStatSize := 0; 211 | FListSize := 0; 212 | FAuthType := POP3AuthAll; 213 | FAutoTLS := False; 214 | FFullSSL := False; 215 | end; 216 | 217 | destructor TPOP3Send.Destroy; 218 | begin 219 | FSock.Free; 220 | FPOP3cap.Free; 221 | FullResult.Free; 222 | inherited Destroy; 223 | end; 224 | 225 | function TPOP3Send.ReadResult(Full: Boolean): Integer; 226 | var 227 | s: string; 228 | begin 229 | Result := 0; 230 | FFullResult.Clear; 231 | s := FSock.RecvString(FTimeout); 232 | if Pos('+OK', s) = 1 then 233 | Result := 1; 234 | FResultString := s; 235 | if Full and (Result = 1) then 236 | repeat 237 | s := FSock.RecvString(FTimeout); 238 | if s = '.' then 239 | Break; 240 | if s <> '' then 241 | if s[1] = '.' then 242 | Delete(s, 1, 1); 243 | FFullResult.Add(s); 244 | until FSock.LastError <> 0; 245 | if not Full and (Result = 1) then 246 | FFullResult.Add(SeparateRight(FResultString, ' ')); 247 | if FSock.LastError <> 0 then 248 | Result := 0; 249 | FResultCode := Result; 250 | end; 251 | 252 | function TPOP3Send.CustomCommand(const Command: string; MultiLine: Boolean): boolean; 253 | begin 254 | FSock.SendString(Command + CRLF); 255 | Result := ReadResult(MultiLine) <> 0; 256 | end; 257 | 258 | function TPOP3Send.AuthLogin: Boolean; 259 | begin 260 | Result := False; 261 | if not CustomCommand('USER ' + FUserName, False) then 262 | exit; 263 | Result := CustomCommand('PASS ' + FPassword, False) 264 | end; 265 | 266 | function TPOP3Send.AuthAPOP: Boolean; 267 | var 268 | s: string; 269 | begin 270 | s := StrToHex(MD5(FTimeStamp + FPassWord)); 271 | Result := CustomCommand('APOP ' + FUserName + ' ' + s, False); 272 | end; 273 | 274 | function TPOP3Send.Connect: Boolean; 275 | begin 276 | // Do not call this function! It is calling by LOGIN method! 277 | FStatCount := 0; 278 | FStatSize := 0; 279 | FSock.CloseSocket; 280 | FSock.LineBuffer := ''; 281 | FSock.Bind(FIPInterface, cAnyPort); 282 | if FSock.LastError = 0 then 283 | FSock.Connect(FTargetHost, FTargetPort); 284 | if FSock.LastError = 0 then 285 | if FFullSSL then 286 | FSock.SSLDoConnect; 287 | Result := FSock.LastError = 0; 288 | end; 289 | 290 | function TPOP3Send.Capability: Boolean; 291 | begin 292 | FPOP3cap.Clear; 293 | Result := CustomCommand('CAPA', True); 294 | if Result then 295 | FPOP3cap.AddStrings(FFullResult); 296 | end; 297 | 298 | function TPOP3Send.Login: Boolean; 299 | var 300 | s, s1: string; 301 | begin 302 | Result := False; 303 | FTimeStamp := ''; 304 | if not Connect then 305 | Exit; 306 | if ReadResult(False) <> 1 then 307 | Exit; 308 | s := SeparateRight(FResultString, '<'); 309 | if s <> FResultString then 310 | begin 311 | s1 := Trim(SeparateLeft(s, '>')); 312 | if s1 <> s then 313 | FTimeStamp := '<' + s1 + '>'; 314 | end; 315 | Result := False; 316 | if Capability then 317 | if FAutoTLS and (Findcap('STLS') <> '') then 318 | if StartTLS then 319 | Capability 320 | else 321 | begin 322 | Result := False; 323 | Exit; 324 | end; 325 | if (FTimeStamp <> '') and not (FAuthType = POP3AuthLogin) then 326 | begin 327 | Result := AuthApop; 328 | if not Result then 329 | begin 330 | if not Connect then 331 | Exit; 332 | if ReadResult(False) <> 1 then 333 | Exit; 334 | end; 335 | end; 336 | if not Result and not (FAuthType = POP3AuthAPOP) then 337 | Result := AuthLogin; 338 | end; 339 | 340 | function TPOP3Send.Logout: Boolean; 341 | begin 342 | Result := CustomCommand('QUIT', False); 343 | FSock.CloseSocket; 344 | end; 345 | 346 | function TPOP3Send.Reset: Boolean; 347 | begin 348 | Result := CustomCommand('RSET', False); 349 | end; 350 | 351 | function TPOP3Send.NoOp: Boolean; 352 | begin 353 | Result := CustomCommand('NOOP', False); 354 | end; 355 | 356 | function TPOP3Send.Stat: Boolean; 357 | var 358 | s: string; 359 | begin 360 | Result := CustomCommand('STAT', False); 361 | if Result then 362 | begin 363 | s := SeparateRight(ResultString, '+OK '); 364 | FStatCount := StrToIntDef(Trim(SeparateLeft(s, ' ')), 0); 365 | FStatSize := StrToIntDef(Trim(SeparateRight(s, ' ')), 0); 366 | end; 367 | end; 368 | 369 | function TPOP3Send.List(Value: Integer): Boolean; 370 | var 371 | s: string; 372 | n: integer; 373 | begin 374 | if Value = 0 then 375 | s := 'LIST' 376 | else 377 | s := 'LIST ' + IntToStr(Value); 378 | Result := CustomCommand(s, Value = 0); 379 | FListSize := 0; 380 | if Result then 381 | if Value <> 0 then 382 | begin 383 | s := SeparateRight(ResultString, '+OK '); 384 | FListSize := StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); 385 | end 386 | else 387 | for n := 0 to FFullResult.Count - 1 do 388 | FListSize := FListSize + StrToIntDef(SeparateLeft(SeparateRight(s, ' '), ' '), 0); 389 | end; 390 | 391 | function TPOP3Send.Retr(Value: Integer): Boolean; 392 | begin 393 | Result := CustomCommand('RETR ' + IntToStr(Value), True); 394 | end; 395 | 396 | //based on code by Miha Vrhovnik 397 | function TPOP3Send.RetrStream(Value: Integer; Stream: TStream): Boolean; 398 | var 399 | s: string; 400 | begin 401 | Result := False; 402 | FFullResult.Clear; 403 | Stream.Size := 0; 404 | FSock.SendString('RETR ' + IntToStr(Value) + CRLF); 405 | 406 | s := FSock.RecvString(FTimeout); 407 | if Pos('+OK', s) = 1 then 408 | Result := True; 409 | FResultString := s; 410 | if Result then begin 411 | repeat 412 | s := FSock.RecvString(FTimeout); 413 | if s = '.' then 414 | Break; 415 | if s <> '' then begin 416 | if s[1] = '.' then 417 | Delete(s, 1, 1); 418 | end; 419 | WriteStrToStream(Stream, s); 420 | WriteStrToStream(Stream, CRLF); 421 | until FSock.LastError <> 0; 422 | end; 423 | 424 | if Result then 425 | FResultCode := 1 426 | else 427 | FResultCode := 0; 428 | end; 429 | 430 | function TPOP3Send.Dele(Value: Integer): Boolean; 431 | begin 432 | Result := CustomCommand('DELE ' + IntToStr(Value), False); 433 | end; 434 | 435 | function TPOP3Send.Top(Value, Maxlines: Integer): Boolean; 436 | begin 437 | Result := CustomCommand('TOP ' + IntToStr(Value) + ' ' + IntToStr(Maxlines), True); 438 | end; 439 | 440 | function TPOP3Send.Uidl(Value: Integer): Boolean; 441 | var 442 | s: string; 443 | begin 444 | if Value = 0 then 445 | s := 'UIDL' 446 | else 447 | s := 'UIDL ' + IntToStr(Value); 448 | Result := CustomCommand(s, Value = 0); 449 | end; 450 | 451 | function TPOP3Send.StartTLS: Boolean; 452 | begin 453 | Result := False; 454 | if CustomCommand('STLS', False) then 455 | begin 456 | Fsock.SSLDoConnect; 457 | Result := FSock.LastError = 0; 458 | end; 459 | end; 460 | 461 | function TPOP3Send.FindCap(const Value: string): string; 462 | var 463 | n: Integer; 464 | s: string; 465 | begin 466 | s := UpperCase(Value); 467 | Result := ''; 468 | for n := 0 to FPOP3cap.Count - 1 do 469 | if Pos(s, UpperCase(FPOP3cap[n])) = 1 then 470 | begin 471 | Result := FPOP3cap[n]; 472 | Break; 473 | end; 474 | end; 475 | 476 | end. 477 | -------------------------------------------------------------------------------- /synapse/slogsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.002.002 | 3 | |==============================================================================| 4 | | Content: SysLog client | 5 | |==============================================================================| 6 | | Copyright (c)1999-2003, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2001-2003. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | | Christian Brosius | 41 | |==============================================================================| 42 | | History: see HISTORY.HTM from distribution package | 43 | | (Found at URL: http://www.ararat.cz/synapse/) | 44 | |==============================================================================} 45 | 46 | {:@abstract(BSD SYSLOG protocol) 47 | 48 | Used RFC: RFC-3164 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$Q-} 55 | {$H+} 56 | 57 | unit slogsend; 58 | 59 | interface 60 | 61 | uses 62 | SysUtils, Classes, 63 | blcksock, synautil; 64 | 65 | const 66 | cSysLogProtocol = '514'; 67 | 68 | FCL_Kernel = 0; 69 | FCL_UserLevel = 1; 70 | FCL_MailSystem = 2; 71 | FCL_System = 3; 72 | FCL_Security = 4; 73 | FCL_Syslogd = 5; 74 | FCL_Printer = 6; 75 | FCL_News = 7; 76 | FCL_UUCP = 8; 77 | FCL_Clock = 9; 78 | FCL_Authorization = 10; 79 | FCL_FTP = 11; 80 | FCL_NTP = 12; 81 | FCL_LogAudit = 13; 82 | FCL_LogAlert = 14; 83 | FCL_Time = 15; 84 | FCL_Local0 = 16; 85 | FCL_Local1 = 17; 86 | FCL_Local2 = 18; 87 | FCL_Local3 = 19; 88 | FCL_Local4 = 20; 89 | FCL_Local5 = 21; 90 | FCL_Local6 = 22; 91 | FCL_Local7 = 23; 92 | 93 | type 94 | {:@abstract(Define possible priority of Syslog message)} 95 | TSyslogSeverity = (Emergency, Alert, Critical, Error, Warning, Notice, Info, 96 | Debug); 97 | 98 | {:@abstract(encoding or decoding of SYSLOG message)} 99 | TSyslogMessage = class(TObject) 100 | private 101 | FFacility:Byte; 102 | FSeverity:TSyslogSeverity; 103 | FDateTime:TDateTime; 104 | FTag:String; 105 | FMessage:String; 106 | FLocalIP:String; 107 | function GetPacketBuf:String; 108 | procedure SetPacketBuf(Value:String); 109 | public 110 | {:Reset values to defaults} 111 | procedure Clear; 112 | published 113 | {:Define facilicity of Syslog message. For specify you may use predefined 114 | FCL_* constants. Default is "FCL_Local0".} 115 | property Facility:Byte read FFacility write FFacility; 116 | 117 | {:Define possible priority of Syslog message. Default is "Debug".} 118 | property Severity:TSyslogSeverity read FSeverity write FSeverity; 119 | 120 | {:date and time of Syslog message} 121 | property DateTime:TDateTime read FDateTime write FDateTime; 122 | 123 | {:This is used for identify process of this message. Default is filename 124 | of your executable file.} 125 | property Tag:String read FTag write FTag; 126 | 127 | {:Text of your message for log.} 128 | property LogMessage:String read FMessage write FMessage; 129 | 130 | {:IP address of message sender.} 131 | property LocalIP:String read FLocalIP write FLocalIP; 132 | 133 | {:This property holds encoded binary SYSLOG packet} 134 | property PacketBuf:String read GetPacketBuf write SetPacketBuf; 135 | end; 136 | 137 | {:@abstract(This object implement BSD SysLog client) 138 | 139 | Note: Are you missing properties for specify server address and port? Look to 140 | parent @link(TSynaClient) too!} 141 | TSyslogSend = class(TSynaClient) 142 | private 143 | FSock: TUDPBlockSocket; 144 | FSysLogMessage: TSysLogMessage; 145 | public 146 | constructor Create; 147 | destructor Destroy; override; 148 | {:Send Syslog UDP packet defined by @link(SysLogMessage).} 149 | function DoIt: Boolean; 150 | published 151 | {:Syslog message for send} 152 | property SysLogMessage:TSysLogMessage read FSysLogMessage write FSysLogMessage; 153 | end; 154 | 155 | {:Simply send packet to specified Syslog server.} 156 | function ToSysLog(const SyslogServer: string; Facil: Byte; 157 | Sever: TSyslogSeverity; const Content: string): Boolean; 158 | 159 | implementation 160 | 161 | function TSyslogMessage.GetPacketBuf:String; 162 | begin 163 | Result := '<' + IntToStr((FFacility * 8) + Ord(FSeverity)) + '>'; 164 | Result := Result + CDateTime(FDateTime) + ' '; 165 | Result := Result + FLocalIP + ' '; 166 | Result := Result + FTag + ': ' + FMessage; 167 | end; 168 | 169 | procedure TSyslogMessage.SetPacketBuf(Value:String); 170 | var StrBuf:String; 171 | IntBuf,Pos:Integer; 172 | begin 173 | if Length(Value) < 1 then exit; 174 | Pos := 1; 175 | if Value[Pos] <> '<' then exit; 176 | Inc(Pos); 177 | // Facility and Severity 178 | StrBuf := ''; 179 | while (Value[Pos] <> '>')do 180 | begin 181 | StrBuf := StrBuf + Value[Pos]; 182 | Inc(Pos); 183 | end; 184 | IntBuf := StrToInt(StrBuf); 185 | FFacility := IntBuf div 8; 186 | case (IntBuf mod 8)of 187 | 0:FSeverity := Emergency; 188 | 1:FSeverity := Alert; 189 | 2:FSeverity := Critical; 190 | 3:FSeverity := Error; 191 | 4:FSeverity := Warning; 192 | 5:FSeverity := Notice; 193 | 6:FSeverity := Info; 194 | 7:FSeverity := Debug; 195 | end; 196 | // DateTime 197 | Inc(Pos); 198 | StrBuf := ''; 199 | // Month 200 | while (Value[Pos] <> ' ')do 201 | begin 202 | StrBuf := StrBuf + Value[Pos]; 203 | Inc(Pos); 204 | end; 205 | StrBuf := StrBuf + Value[Pos]; 206 | Inc(Pos); 207 | // Day 208 | while (Value[Pos] <> ' ')do 209 | begin 210 | StrBuf := StrBuf + Value[Pos]; 211 | Inc(Pos); 212 | end; 213 | StrBuf := StrBuf + Value[Pos]; 214 | Inc(Pos); 215 | // Time 216 | while (Value[Pos] <> ' ')do 217 | begin 218 | StrBuf := StrBuf + Value[Pos]; 219 | Inc(Pos); 220 | end; 221 | FDateTime := DecodeRFCDateTime(StrBuf); 222 | Inc(Pos); 223 | 224 | // LocalIP 225 | StrBuf := ''; 226 | while (Value[Pos] <> ' ')do 227 | begin 228 | StrBuf := StrBuf + Value[Pos]; 229 | Inc(Pos); 230 | end; 231 | FLocalIP := StrBuf; 232 | Inc(Pos); 233 | // Tag 234 | StrBuf := ''; 235 | while (Value[Pos] <> ':')do 236 | begin 237 | StrBuf := StrBuf + Value[Pos]; 238 | Inc(Pos); 239 | end; 240 | FTag := StrBuf; 241 | // LogMessage 242 | Inc(Pos); 243 | StrBuf := ''; 244 | while (Pos <= Length(Value))do 245 | begin 246 | StrBuf := StrBuf + Value[Pos]; 247 | Inc(Pos); 248 | end; 249 | FMessage := TrimSP(StrBuf); 250 | end; 251 | 252 | procedure TSysLogMessage.Clear; 253 | begin 254 | FFacility := FCL_Local0; 255 | FSeverity := Debug; 256 | FTag := ExtractFileName(ParamStr(0)); 257 | FMessage := ''; 258 | FLocalIP := '0.0.0.0'; 259 | end; 260 | 261 | //------------------------------------------------------------------------------ 262 | 263 | constructor TSyslogSend.Create; 264 | begin 265 | inherited Create; 266 | FSock := TUDPBlockSocket.Create; 267 | FSysLogMessage := TSysLogMessage.Create; 268 | FTargetPort := cSysLogProtocol; 269 | end; 270 | 271 | destructor TSyslogSend.Destroy; 272 | begin 273 | FSock.Free; 274 | FSysLogMessage.Free; 275 | inherited Destroy; 276 | end; 277 | 278 | function TSyslogSend.DoIt: Boolean; 279 | var 280 | L: TStringList; 281 | begin 282 | Result := False; 283 | L := TStringList.Create; 284 | try 285 | FSock.ResolveNameToIP(FSock.Localname, L); 286 | if L.Count < 1 then 287 | FSysLogMessage.LocalIP := '0.0.0.0' 288 | else 289 | FSysLogMessage.LocalIP := L[0]; 290 | finally 291 | L.Free; 292 | end; 293 | FSysLogMessage.DateTime := Now; 294 | if Length(FSysLogMessage.PacketBuf) <= 1024 then 295 | begin 296 | FSock.Connect(FTargetHost, FTargetPort); 297 | FSock.SendString(FSysLogMessage.PacketBuf); 298 | Result := FSock.LastError = 0; 299 | end; 300 | end; 301 | 302 | {==============================================================================} 303 | 304 | function ToSysLog(const SyslogServer: string; Facil: Byte; 305 | Sever: TSyslogSeverity; const Content: string): Boolean; 306 | begin 307 | with TSyslogSend.Create do 308 | try 309 | TargetHost :=SyslogServer; 310 | SysLogMessage.Facility := Facil; 311 | SysLogMessage.Severity := Sever; 312 | SysLogMessage.LogMessage := Content; 313 | Result := DoIt; 314 | finally 315 | Free; 316 | end; 317 | end; 318 | 319 | end. 320 | -------------------------------------------------------------------------------- /synapse/sntpsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 003.000.002 | 3 | |==============================================================================| 4 | | Content: SNTP client | 5 | |==============================================================================| 6 | | Copyright (c)1999-2007, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2000-2007. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | | Patrick Chevalley | 41 | |==============================================================================| 42 | | History: see HISTORY.HTM from distribution package | 43 | | (Found at URL: http://www.ararat.cz/synapse/) | 44 | |==============================================================================} 45 | 46 | {:@abstract( NTP and SNTP client) 47 | 48 | Used RFC: RFC-1305, RFC-2030 49 | } 50 | 51 | {$IFDEF FPC} 52 | {$MODE DELPHI} 53 | {$ENDIF} 54 | {$Q-} 55 | {$H+} 56 | 57 | unit sntpsend; 58 | 59 | interface 60 | 61 | uses 62 | SysUtils, 63 | synsock, blcksock, synautil; 64 | 65 | const 66 | cNtpProtocol = '123'; 67 | 68 | type 69 | 70 | {:@abstract(Record containing the NTP packet.)} 71 | TNtp = packed record 72 | mode: Byte; 73 | stratum: Byte; 74 | poll: Byte; 75 | Precision: Byte; 76 | RootDelay: Longint; 77 | RootDisperson: Longint; 78 | RefID: Longint; 79 | Ref1: Longint; 80 | Ref2: Longint; 81 | Org1: Longint; 82 | Org2: Longint; 83 | Rcv1: Longint; 84 | Rcv2: Longint; 85 | Xmit1: Longint; 86 | Xmit2: Longint; 87 | end; 88 | 89 | {:@abstract(Implementation of NTP and SNTP client protocol), 90 | include time synchronisation. It can send NTP or SNTP time queries, or it 91 | can receive NTP broadcasts too. 92 | 93 | Note: Are you missing properties for specify server address and port? Look to 94 | parent @link(TSynaClient) too!} 95 | TSNTPSend = class(TSynaClient) 96 | private 97 | FNTPReply: TNtp; 98 | FNTPTime: TDateTime; 99 | FNTPOffset: double; 100 | FNTPDelay: double; 101 | FMaxSyncDiff: double; 102 | FSyncTime: Boolean; 103 | FSock: TUDPBlockSocket; 104 | FBuffer: string; 105 | FLi, FVn, Fmode : byte; 106 | function StrToNTP(const Value: AnsiString): TNtp; 107 | function NTPtoStr(const Value: Tntp): AnsiString; 108 | procedure ClearNTP(var Value: Tntp); 109 | public 110 | constructor Create; 111 | destructor Destroy; override; 112 | 113 | {:Decode 128 bit timestamp used in NTP packet to TDateTime type.} 114 | function DecodeTs(Nsec, Nfrac: Longint): TDateTime; 115 | 116 | {:Decode TDateTime type to 128 bit timestamp used in NTP packet.} 117 | procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); 118 | 119 | {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all 120 | is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are 121 | valid.} 122 | function GetSNTP: Boolean; 123 | 124 | {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all 125 | is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are 126 | valid. Result time is after all needed corrections.} 127 | function GetNTP: Boolean; 128 | 129 | {:Wait for broadcast NTP packet. If all OK, result is @true and 130 | @link(NTPReply) and @link(NTPTime) are valid.} 131 | function GetBroadcastNTP: Boolean; 132 | 133 | {:Holds last received NTP packet.} 134 | property NTPReply: TNtp read FNTPReply; 135 | published 136 | {:Date and time of remote NTP or SNTP server. (UTC time!!!)} 137 | property NTPTime: TDateTime read FNTPTime; 138 | 139 | {:Offset between your computer and remote NTP or SNTP server.} 140 | property NTPOffset: Double read FNTPOffset; 141 | 142 | {:Delay between your computer and remote NTP or SNTP server.} 143 | property NTPDelay: Double read FNTPDelay; 144 | 145 | {:Define allowed maximum difference between your time and remote time for 146 | synchronising time. If difference is bigger, your system time is not 147 | changed!} 148 | property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff; 149 | 150 | {:If @true, after successfull getting time is local computer clock 151 | synchronised to given time. 152 | For synchronising time you must have proper rights! (Usually Administrator)} 153 | property SyncTime: Boolean read FSyncTime write FSyncTime; 154 | 155 | {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} 156 | property Sock: TUDPBlockSocket read FSock; 157 | end; 158 | 159 | implementation 160 | 161 | constructor TSNTPSend.Create; 162 | begin 163 | inherited Create; 164 | FSock := TUDPBlockSocket.Create; 165 | FTimeout := 5000; 166 | FTargetPort := cNtpProtocol; 167 | FMaxSyncDiff := 3600; 168 | FSyncTime := False; 169 | end; 170 | 171 | destructor TSNTPSend.Destroy; 172 | begin 173 | FSock.Free; 174 | inherited Destroy; 175 | end; 176 | 177 | function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp; 178 | begin 179 | if length(FBuffer) >= SizeOf(Result) then 180 | begin 181 | Result.mode := ord(Value[1]); 182 | Result.stratum := ord(Value[2]); 183 | Result.poll := ord(Value[3]); 184 | Result.Precision := ord(Value[4]); 185 | Result.RootDelay := DecodeLongInt(value, 5); 186 | Result.RootDisperson := DecodeLongInt(value, 9); 187 | Result.RefID := DecodeLongInt(value, 13); 188 | Result.Ref1 := DecodeLongInt(value, 17); 189 | Result.Ref2 := DecodeLongInt(value, 21); 190 | Result.Org1 := DecodeLongInt(value, 25); 191 | Result.Org2 := DecodeLongInt(value, 29); 192 | Result.Rcv1 := DecodeLongInt(value, 33); 193 | Result.Rcv2 := DecodeLongInt(value, 37); 194 | Result.Xmit1 := DecodeLongInt(value, 41); 195 | Result.Xmit2 := DecodeLongInt(value, 45); 196 | end; 197 | 198 | end; 199 | 200 | function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString; 201 | begin 202 | SetLength(Result, 4); 203 | Result[1] := AnsiChar(Value.mode); 204 | Result[2] := AnsiChar(Value.stratum); 205 | Result[3] := AnsiChar(Value.poll); 206 | Result[4] := AnsiChar(Value.precision); 207 | Result := Result + CodeLongInt(Value.RootDelay); 208 | Result := Result + CodeLongInt(Value.RootDisperson); 209 | Result := Result + CodeLongInt(Value.RefID); 210 | Result := Result + CodeLongInt(Value.Ref1); 211 | Result := Result + CodeLongInt(Value.Ref2); 212 | Result := Result + CodeLongInt(Value.Org1); 213 | Result := Result + CodeLongInt(Value.Org2); 214 | Result := Result + CodeLongInt(Value.Rcv1); 215 | Result := Result + CodeLongInt(Value.Rcv2); 216 | Result := Result + CodeLongInt(Value.Xmit1); 217 | Result := Result + CodeLongInt(Value.Xmit2); 218 | end; 219 | 220 | procedure TSNTPSend.ClearNTP(var Value: Tntp); 221 | begin 222 | Value.mode := 0; 223 | Value.stratum := 0; 224 | Value.poll := 0; 225 | Value.Precision := 0; 226 | Value.RootDelay := 0; 227 | Value.RootDisperson := 0; 228 | Value.RefID := 0; 229 | Value.Ref1 := 0; 230 | Value.Ref2 := 0; 231 | Value.Org1 := 0; 232 | Value.Org2 := 0; 233 | Value.Rcv1 := 0; 234 | Value.Rcv2 := 0; 235 | Value.Xmit1 := 0; 236 | Value.Xmit2 := 0; 237 | end; 238 | 239 | function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime; 240 | const 241 | maxi = 4294967295.0; 242 | var 243 | d, d1: Double; 244 | begin 245 | d := Nsec; 246 | if d < 0 then 247 | d := maxi + d + 1; 248 | d1 := Nfrac; 249 | if d1 < 0 then 250 | d1 := maxi + d1 + 1; 251 | d1 := d1 / maxi; 252 | d1 := Trunc(d1 * 10000) / 10000; 253 | Result := (d + d1) / 86400; 254 | Result := Result + 2; 255 | end; 256 | 257 | procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint); 258 | const 259 | maxi = 4294967295.0; 260 | maxilongint = 2147483647; 261 | var 262 | d, d1: Double; 263 | begin 264 | d := (dt - 2) * 86400; 265 | d1 := frac(d); 266 | if d > maxilongint then 267 | d := d - maxi - 1; 268 | d := trunc(d); 269 | d1 := Trunc(d1 * 10000) / 10000; 270 | d1 := d1 * maxi; 271 | if d1 > maxilongint then 272 | d1 := d1 - maxi - 1; 273 | Nsec:=trunc(d); 274 | Nfrac:=trunc(d1); 275 | end; 276 | 277 | function TSNTPSend.GetBroadcastNTP: Boolean; 278 | var 279 | x: Integer; 280 | begin 281 | Result := False; 282 | FSock.Bind(FIPInterface, FTargetPort); 283 | FBuffer := FSock.RecvPacket(FTimeout); 284 | if FSock.LastError = 0 then 285 | begin 286 | x := Length(FBuffer); 287 | if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then 288 | if x >= SizeOf(NTPReply) then 289 | begin 290 | FNTPReply := StrToNTP(FBuffer); 291 | FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); 292 | if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then 293 | SetUTTime(FNTPTime); 294 | Result := True; 295 | end; 296 | end; 297 | end; 298 | 299 | function TSNTPSend.GetSNTP: Boolean; 300 | var 301 | q: TNtp; 302 | x: Integer; 303 | begin 304 | Result := False; 305 | FSock.CloseSocket; 306 | FSock.Bind(FIPInterface, cAnyPort); 307 | FSock.Connect(FTargetHost, FTargetPort); 308 | ClearNtp(q); 309 | q.mode := $1B; 310 | FBuffer := NTPtoStr(q); 311 | FSock.SendString(FBuffer); 312 | FBuffer := FSock.RecvPacket(FTimeout); 313 | if FSock.LastError = 0 then 314 | begin 315 | x := Length(FBuffer); 316 | if x >= SizeOf(NTPReply) then 317 | begin 318 | FNTPReply := StrToNTP(FBuffer); 319 | FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); 320 | if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then 321 | SetUTTime(FNTPTime); 322 | Result := True; 323 | end; 324 | end; 325 | end; 326 | 327 | function TSNTPSend.GetNTP: Boolean; 328 | var 329 | q: TNtp; 330 | x: Integer; 331 | t1, t2, t3, t4 : TDateTime; 332 | begin 333 | Result := False; 334 | FSock.CloseSocket; 335 | FSock.Bind(FIPInterface, cAnyPort); 336 | FSock.Connect(FTargetHost, FTargetPort); 337 | ClearNtp(q); 338 | q.mode := $1B; 339 | t1 := GetUTTime; 340 | EncodeTs(t1, q.org1, q.org2); 341 | FBuffer := NTPtoStr(q); 342 | FSock.SendString(FBuffer); 343 | FBuffer := FSock.RecvPacket(FTimeout); 344 | if FSock.LastError = 0 then 345 | begin 346 | x := Length(FBuffer); 347 | t4 := GetUTTime; 348 | if x >= SizeOf(NTPReply) then 349 | begin 350 | FNTPReply := StrToNTP(FBuffer); 351 | FLi := (NTPReply.mode and $C0) shr 6; 352 | FVn := (NTPReply.mode and $38) shr 3; 353 | Fmode := NTPReply.mode and $07; 354 | if (Fli < 3) and (Fmode = 4) and 355 | (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and 356 | (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0) 357 | then begin 358 | t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2); 359 | t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2); 360 | FNTPDelay := (T4 - T1) - (T2 - T3); 361 | FNTPTime := t3 + FNTPDelay / 2; 362 | FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400; 363 | FNTPDelay := FNTPDelay * 86400; 364 | if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then 365 | SetUTTime(FNTPTime); 366 | Result := True; 367 | end 368 | else result:=false; 369 | end; 370 | end; 371 | end; 372 | 373 | end. 374 | -------------------------------------------------------------------------------- /synapse/ssl_cryptlib.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.000 | 3 | |==============================================================================| 4 | | Content: SSL/SSH support by Peter Gutmann's CryptLib | 5 | |==============================================================================| 6 | | Copyright (c)1999-2005, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2005. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract(SSL/SSH plugin for CryptLib) 46 | 47 | This plugin requires cl32.dll at least version 3.2.0! It can be used on Win32 48 | and Linux. This library is staticly linked - when you compile your application 49 | with this plugin, you MUST distribute it with Cryptib library, otherwise you 50 | cannot run your application! 51 | 52 | It can work with keys and certificates stored as PKCS#15 only! It must be stored 53 | as disk file only, you cannot load them from memory! Each file can hold multiple 54 | keys and certificates. You must identify it by 'label' stored in 55 | @link(TSSLCryptLib.PrivateKeyLabel). 56 | 57 | If you need to use secure connection and authorize self by certificate 58 | (each SSL/TLS server or client with client authorization), then use 59 | @link(TCustomSSL.PrivateKeyFile), @link(TSSLCryptLib.PrivateKeyLabel) and 60 | @link(TCustomSSL.KeyPassword) properties. 61 | 62 | If you need to use server what verifying client certificates, then use 63 | @link(TCustomSSL.CertCAFile) as PKCS#15 file with public keyas of allowed clients. Clients 64 | with non-matching certificates will be rejected by cryptLib. 65 | 66 | This plugin is capable to create Ad-Hoc certificates. When you start SSL/TLS 67 | server without explicitly assigned key and certificate, then this plugin create 68 | Ad-Hoc key and certificate for each incomming connection by self. It slowdown 69 | accepting of new connections! 70 | 71 | You can use this plugin for SSHv2 connections too! You must explicitly set 72 | @link(TCustomSSL.SSLType) to value LT_SSHv2 and set @link(TCustomSSL.username) 73 | and @link(TCustomSSL.password). You can use special SSH channels too, see 74 | @link(TCustomSSL). 75 | } 76 | 77 | {$IFDEF FPC} 78 | {$MODE DELPHI} 79 | {$ENDIF} 80 | {$H+} 81 | 82 | unit ssl_cryptlib; 83 | 84 | interface 85 | 86 | uses 87 | SysUtils, 88 | blcksock, synsock, synautil, synacode, 89 | cryptlib; 90 | 91 | type 92 | {:@abstract(class implementing CryptLib SSL/SSH plugin.) 93 | Instance of this class will be created for each @link(TTCPBlockSocket). 94 | You not need to create instance of this class, all is done by Synapse itself!} 95 | TSSLCryptLib = class(TCustomSSL) 96 | protected 97 | FCryptSession: CRYPT_SESSION; 98 | FPrivateKeyLabel: string; 99 | FDelCert: Boolean; 100 | FReadBuffer: string; 101 | function SSLCheck(Value: integer): Boolean; 102 | function Init(server:Boolean): Boolean; 103 | function DeInit: Boolean; 104 | function Prepare(server:Boolean): Boolean; 105 | function GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; 106 | function CreateSelfSignedCert(Host: string): Boolean; override; 107 | function PopAll: string; 108 | public 109 | {:See @inherited} 110 | constructor Create(const Value: TTCPBlockSocket); override; 111 | destructor Destroy; override; 112 | {:See @inherited} 113 | function LibVersion: String; override; 114 | {:See @inherited} 115 | function LibName: String; override; 116 | {:See @inherited} 117 | procedure Assign(const Value: TCustomSSL); override; 118 | {:See @inherited and @link(ssl_cryptlib) for more details.} 119 | function Connect: boolean; override; 120 | {:See @inherited and @link(ssl_cryptlib) for more details.} 121 | function Accept: boolean; override; 122 | {:See @inherited} 123 | function Shutdown: boolean; override; 124 | {:See @inherited} 125 | function BiShutdown: boolean; override; 126 | {:See @inherited} 127 | function SendBuffer(Buffer: TMemory; Len: Integer): Integer; override; 128 | {:See @inherited} 129 | function RecvBuffer(Buffer: TMemory; Len: Integer): Integer; override; 130 | {:See @inherited} 131 | function WaitingData: Integer; override; 132 | {:See @inherited} 133 | function GetSSLVersion: string; override; 134 | {:See @inherited} 135 | function GetPeerSubject: string; override; 136 | {:See @inherited} 137 | function GetPeerIssuer: string; override; 138 | {:See @inherited} 139 | function GetPeerName: string; override; 140 | {:See @inherited} 141 | function GetPeerFingerprint: string; override; 142 | published 143 | {:name of certificate/key within PKCS#15 file. It can hold more then one 144 | certificate/key and each certificate/key must have unique label within one file.} 145 | property PrivateKeyLabel: string read FPrivateKeyLabel Write FPrivateKeyLabel; 146 | end; 147 | 148 | implementation 149 | 150 | {==============================================================================} 151 | 152 | constructor TSSLCryptLib.Create(const Value: TTCPBlockSocket); 153 | begin 154 | inherited Create(Value); 155 | FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); 156 | FPrivateKeyLabel := 'synapse'; 157 | FDelCert := false; 158 | end; 159 | 160 | destructor TSSLCryptLib.Destroy; 161 | begin 162 | DeInit; 163 | inherited Destroy; 164 | end; 165 | 166 | procedure TSSLCryptLib.Assign(const Value: TCustomSSL); 167 | begin 168 | inherited Assign(Value); 169 | if Value is TSSLCryptLib then 170 | begin 171 | FPrivateKeyLabel := TSSLCryptLib(Value).privatekeyLabel; 172 | end; 173 | end; 174 | 175 | function TSSLCryptLib.GetString(const cryptHandle: CRYPT_HANDLE; const attributeType: CRYPT_ATTRIBUTE_TYPE): string; 176 | var 177 | l: integer; 178 | begin 179 | l := 0; 180 | cryptGetAttributeString(cryptHandle, attributeType, nil, l); 181 | setlength(Result, l); 182 | cryptGetAttributeString(cryptHandle, attributeType, pointer(Result), l); 183 | setlength(Result, l); 184 | end; 185 | 186 | function TSSLCryptLib.LibVersion: String; 187 | var 188 | x: integer; 189 | begin 190 | Result := GetString(CRYPT_UNUSED, CRYPT_OPTION_INFO_DESCRIPTION); 191 | cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MAJORVERSION, x); 192 | Result := Result + ' v' + IntToStr(x); 193 | cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_MINORVERSION, x); 194 | Result := Result + '.' + IntToStr(x); 195 | cryptGetAttribute(CRYPT_UNUSED, CRYPT_OPTION_INFO_STEPPING, x); 196 | Result := Result + '.' + IntToStr(x); 197 | end; 198 | 199 | function TSSLCryptLib.LibName: String; 200 | begin 201 | Result := 'ssl_cryptlib'; 202 | end; 203 | 204 | function TSSLCryptLib.SSLCheck(Value: integer): Boolean; 205 | begin 206 | Result := true; 207 | FLastErrorDesc := ''; 208 | if Value = CRYPT_ERROR_COMPLETE then 209 | Value := 0; 210 | FLastError := Value; 211 | if FLastError <> 0 then 212 | begin 213 | Result := False; 214 | FLastErrorDesc := GetString(FCryptSession, CRYPT_ATTRIBUTE_INT_ERRORMESSAGE); 215 | end; 216 | end; 217 | 218 | function TSSLCryptLib.CreateSelfSignedCert(Host: string): Boolean; 219 | var 220 | privateKey: CRYPT_CONTEXT; 221 | keyset: CRYPT_KEYSET; 222 | cert: CRYPT_CERTIFICATE; 223 | publicKey: CRYPT_CONTEXT; 224 | begin 225 | Result := False; 226 | if FPrivatekeyFile = '' then 227 | FPrivatekeyFile := GetTempFile('', 'key'); 228 | cryptCreateContext(privateKey, CRYPT_UNUSED, CRYPT_ALGO_RSA); 229 | cryptSetAttributeString(privateKey, CRYPT_CTXINFO_LABEL, Pointer(FPrivatekeyLabel), 230 | Length(FPrivatekeyLabel)); 231 | cryptSetAttribute(privateKey, CRYPT_CTXINFO_KEYSIZE, 1024); 232 | cryptGenerateKey(privateKey); 233 | cryptKeysetOpen(keyset, CRYPT_UNUSED, CRYPT_KEYSET_FILE, PChar(FPrivatekeyFile), CRYPT_KEYOPT_CREATE); 234 | FDelCert := True; 235 | cryptAddPrivateKey(keyset, privateKey, PChar(FKeyPassword)); 236 | cryptCreateCert(cert, CRYPT_UNUSED, CRYPT_CERTTYPE_CERTIFICATE); 237 | cryptSetAttribute(cert, CRYPT_CERTINFO_XYZZY, 1); 238 | cryptGetPublicKey(keyset, publicKey, CRYPT_KEYID_NAME, PChar(FPrivatekeyLabel)); 239 | cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTPUBLICKEYINFO, publicKey); 240 | cryptSetAttributeString(cert, CRYPT_CERTINFO_COMMONNAME, Pointer(host), Length(host)); 241 | cryptSignCert(cert, privateKey); 242 | cryptAddPublicKey(keyset, cert); 243 | cryptKeysetClose(keyset); 244 | cryptDestroyCert(cert); 245 | cryptDestroyContext(privateKey); 246 | cryptDestroyContext(publicKey); 247 | Result := True; 248 | end; 249 | 250 | function TSSLCryptLib.PopAll: string; 251 | const 252 | BufferMaxSize = 32768; 253 | var 254 | Outbuffer: string; 255 | WriteLen: integer; 256 | begin 257 | Result := ''; 258 | repeat 259 | setlength(outbuffer, BufferMaxSize); 260 | Writelen := 0; 261 | SSLCheck(CryptPopData(FCryptSession, @OutBuffer[1], BufferMaxSize, Writelen)); 262 | if FLastError <> 0 then 263 | Break; 264 | if WriteLen > 0 then 265 | begin 266 | setlength(outbuffer, WriteLen); 267 | Result := Result + outbuffer; 268 | end; 269 | until WriteLen = 0; 270 | end; 271 | 272 | function TSSLCryptLib.Init(server:Boolean): Boolean; 273 | var 274 | st: CRYPT_SESSION_TYPE; 275 | keysetobj: CRYPT_KEYSET; 276 | cryptContext: CRYPT_CONTEXT; 277 | x: integer; 278 | begin 279 | Result := False; 280 | FLastErrorDesc := ''; 281 | FLastError := 0; 282 | FDelCert := false; 283 | FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); 284 | if server then 285 | case FSSLType of 286 | LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: 287 | st := CRYPT_SESSION_SSL_SERVER; 288 | LT_SSHv2: 289 | st := CRYPT_SESSION_SSH_SERVER; 290 | else 291 | Exit; 292 | end 293 | else 294 | case FSSLType of 295 | LT_all, LT_SSLv3, LT_TLSv1, LT_TLSv1_1: 296 | st := CRYPT_SESSION_SSL; 297 | LT_SSHv2: 298 | st := CRYPT_SESSION_SSH; 299 | else 300 | Exit; 301 | end; 302 | if not SSLCheck(cryptCreateSession(FcryptSession, CRYPT_UNUSED, st)) then 303 | Exit; 304 | x := -1; 305 | case FSSLType of 306 | LT_SSLv3: 307 | x := 0; 308 | LT_TLSv1: 309 | x := 1; 310 | LT_TLSv1_1: 311 | x := 2; 312 | end; 313 | if x >= 0 then 314 | if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x)) then 315 | Exit; 316 | if FUsername <> '' then 317 | begin 318 | cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_USERNAME, 319 | Pointer(FUsername), Length(FUsername)); 320 | cryptSetAttributeString(FcryptSession, CRYPT_SESSINFO_PASSWORD, 321 | Pointer(FPassword), Length(FPassword)); 322 | end; 323 | if FSSLType = LT_SSHv2 then 324 | if FSSHChannelType <> '' then 325 | begin 326 | cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL, CRYPT_UNUSED); 327 | cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_TYPE, 328 | Pointer(FSSHChannelType), Length(FSSHChannelType)); 329 | if FSSHChannelArg1 <> '' then 330 | cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG1, 331 | Pointer(FSSHChannelArg1), Length(FSSHChannelArg1)); 332 | if FSSHChannelArg2 <> '' then 333 | cryptSetAttributeString(FCryptSession, CRYPT_SESSINFO_SSH_CHANNEL_ARG2, 334 | Pointer(FSSHChannelArg2), Length(FSSHChannelArg2)); 335 | end; 336 | 337 | 338 | if server and (FPrivatekeyFile = '') then 339 | begin 340 | if FPrivatekeyLabel = '' then 341 | FPrivatekeyLabel := 'synapse'; 342 | if FkeyPassword = '' then 343 | FkeyPassword := 'synapse'; 344 | CreateSelfSignedcert(FSocket.ResolveIPToName(FSocket.GetRemoteSinIP)); 345 | end; 346 | 347 | if (FPrivatekeyLabel <> '') and (FPrivatekeyFile <> '') then 348 | begin 349 | if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE, 350 | PChar(FPrivatekeyFile), CRYPT_KEYOPT_READONLY)) then 351 | Exit; 352 | try 353 | if not SSLCheck(cryptGetPrivateKey(KeySetObj, cryptcontext, CRYPT_KEYID_NAME, 354 | PChar(FPrivatekeyLabel), PChar(FKeyPassword))) then 355 | Exit; 356 | if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_PRIVATEKEY, 357 | cryptcontext)) then 358 | Exit; 359 | finally 360 | cryptKeysetClose(keySetObj); 361 | cryptDestroyContext(cryptcontext); 362 | end; 363 | end; 364 | if server and FVerifyCert then 365 | begin 366 | if not SSLCheck(cryptKeysetOpen(KeySetObj, CRYPT_UNUSED, CRYPT_KEYSET_FILE, 367 | PChar(FCertCAFile), CRYPT_KEYOPT_READONLY)) then 368 | Exit; 369 | try 370 | if not SSLCheck(cryptSetAttribute(FcryptSession, CRYPT_SESSINFO_KEYSET, 371 | keySetObj)) then 372 | Exit; 373 | finally 374 | cryptKeysetClose(keySetObj); 375 | end; 376 | end; 377 | Result := true; 378 | end; 379 | 380 | function TSSLCryptLib.DeInit: Boolean; 381 | begin 382 | Result := True; 383 | if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then 384 | CryptDestroySession(FcryptSession); 385 | FcryptSession := CRYPT_SESSION(CRYPT_SESSION_NONE); 386 | FSSLEnabled := False; 387 | if FDelCert then 388 | Deletefile(FPrivatekeyFile); 389 | end; 390 | 391 | function TSSLCryptLib.Prepare(server:Boolean): Boolean; 392 | begin 393 | Result := false; 394 | DeInit; 395 | if Init(server) then 396 | Result := true 397 | else 398 | DeInit; 399 | end; 400 | 401 | function TSSLCryptLib.Connect: boolean; 402 | begin 403 | Result := False; 404 | if FSocket.Socket = INVALID_SOCKET then 405 | Exit; 406 | if Prepare(false) then 407 | begin 408 | if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then 409 | Exit; 410 | if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then 411 | Exit; 412 | FSSLEnabled := True; 413 | Result := True; 414 | FReadBuffer := ''; 415 | end; 416 | end; 417 | 418 | function TSSLCryptLib.Accept: boolean; 419 | begin 420 | Result := False; 421 | if FSocket.Socket = INVALID_SOCKET then 422 | Exit; 423 | if Prepare(true) then 424 | begin 425 | if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_NETWORKSOCKET, FSocket.Socket)) then 426 | Exit; 427 | if not SSLCheck(cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 1)) then 428 | Exit; 429 | FSSLEnabled := True; 430 | Result := True; 431 | FReadBuffer := ''; 432 | end; 433 | end; 434 | 435 | function TSSLCryptLib.Shutdown: boolean; 436 | begin 437 | Result := BiShutdown; 438 | end; 439 | 440 | function TSSLCryptLib.BiShutdown: boolean; 441 | begin 442 | if FcryptSession <> CRYPT_SESSION(CRYPT_SESSION_NONE) then 443 | cryptSetAttribute(FCryptSession, CRYPT_SESSINFO_ACTIVE, 0); 444 | DeInit; 445 | FReadBuffer := ''; 446 | Result := True; 447 | end; 448 | 449 | function TSSLCryptLib.SendBuffer(Buffer: TMemory; Len: Integer): Integer; 450 | var 451 | l: integer; 452 | begin 453 | FLastError := 0; 454 | FLastErrorDesc := ''; 455 | SSLCheck(cryptPushData(FCryptSession, Buffer, Len, L)); 456 | cryptFlushData(FcryptSession); 457 | Result := l; 458 | end; 459 | 460 | function TSSLCryptLib.RecvBuffer(Buffer: TMemory; Len: Integer): Integer; 461 | var 462 | l: integer; 463 | begin 464 | FLastError := 0; 465 | FLastErrorDesc := ''; 466 | if Length(FReadBuffer) = 0 then 467 | FReadBuffer := PopAll; 468 | if Len > Length(FReadBuffer) then 469 | Len := Length(FReadBuffer); 470 | Move(Pointer(FReadBuffer)^, buffer^, Len); 471 | Delete(FReadBuffer, 1, Len); 472 | Result := Len; 473 | end; 474 | 475 | function TSSLCryptLib.WaitingData: Integer; 476 | begin 477 | Result := Length(FReadBuffer); 478 | end; 479 | 480 | function TSSLCryptLib.GetSSLVersion: string; 481 | var 482 | x: integer; 483 | begin 484 | Result := ''; 485 | if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then 486 | Exit; 487 | cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_VERSION, x); 488 | if FSSLType in [LT_SSLv3, LT_TLSv1, LT_TLSv1_1, LT_all] then 489 | case x of 490 | 0: 491 | Result := 'SSLv3'; 492 | 1: 493 | Result := 'TLSv1'; 494 | 2: 495 | Result := 'TLSv1.1'; 496 | end; 497 | if FSSLType in [LT_SSHv2] then 498 | case x of 499 | 0: 500 | Result := 'SSHv1'; 501 | 1: 502 | Result := 'SSHv2'; 503 | end; 504 | end; 505 | 506 | function TSSLCryptLib.GetPeerSubject: string; 507 | var 508 | cert: CRYPT_CERTIFICATE; 509 | begin 510 | Result := ''; 511 | if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then 512 | Exit; 513 | cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); 514 | cryptSetAttribute(cert, CRYPT_CERTINFO_SUBJECTNAME, CRYPT_UNUSED); 515 | Result := GetString(cert, CRYPT_CERTINFO_DN); 516 | cryptDestroyCert(cert); 517 | end; 518 | 519 | function TSSLCryptLib.GetPeerName: string; 520 | var 521 | cert: CRYPT_CERTIFICATE; 522 | begin 523 | Result := ''; 524 | if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then 525 | Exit; 526 | cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); 527 | cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED); 528 | Result := GetString(cert, CRYPT_CERTINFO_COMMONNAME); 529 | cryptDestroyCert(cert); 530 | end; 531 | 532 | function TSSLCryptLib.GetPeerIssuer: string; 533 | var 534 | cert: CRYPT_CERTIFICATE; 535 | begin 536 | Result := ''; 537 | if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then 538 | Exit; 539 | cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); 540 | cryptSetAttribute(cert, CRYPT_CERTINFO_ISSUERNAME, CRYPT_UNUSED); 541 | Result := GetString(cert, CRYPT_CERTINFO_DN); 542 | cryptDestroyCert(cert); 543 | end; 544 | 545 | function TSSLCryptLib.GetPeerFingerprint: string; 546 | var 547 | cert: CRYPT_CERTIFICATE; 548 | begin 549 | Result := ''; 550 | if FcryptSession = CRYPT_SESSION(CRYPT_SESSION_NONE) then 551 | Exit; 552 | cryptGetAttribute(FCryptSession, CRYPT_SESSINFO_RESPONSE, cert); 553 | Result := GetString(cert, CRYPT_CERTINFO_FINGERPRINT); 554 | Result := MD5(Result); 555 | cryptDestroyCert(cert); 556 | end; 557 | 558 | {==============================================================================} 559 | 560 | initialization 561 | if cryptInit = CRYPT_OK then 562 | SSLImplementation := TSSLCryptLib; 563 | cryptAddRandom(nil, CRYPT_RANDOM_SLOWPOLL); 564 | 565 | finalization 566 | cryptEnd; 567 | 568 | end. 569 | 570 | -------------------------------------------------------------------------------- /synapse/ssl_streamsec.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crossrw/mqttClient/7f392ca2d692b119ecfb35c6b034f59c6640617d/synapse/ssl_streamsec.pas -------------------------------------------------------------------------------- /synapse/synacode.dcu: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crossrw/mqttClient/7f392ca2d692b119ecfb35c6b034f59c6640617d/synapse/synacode.dcu -------------------------------------------------------------------------------- /synapse/synadbg.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.000 | 3 | |==============================================================================| 4 | | Content: Socket debug tools | 5 | |==============================================================================| 6 | | Copyright (c)2008, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2008. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract(Socket debug tools) 46 | 47 | Routines for help with debugging of events on the Sockets. 48 | } 49 | 50 | 51 | unit synadbg; 52 | 53 | interface 54 | 55 | uses 56 | blcksock, synsock, synautil, classes, sysutils; 57 | 58 | type 59 | TSynaDebug = class(TObject) 60 | class procedure HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); 61 | class procedure HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); 62 | end; 63 | 64 | procedure AppendToLog(const value: Ansistring); 65 | 66 | var 67 | LogFile: string; 68 | 69 | implementation 70 | 71 | procedure AppendToLog(const value: Ansistring); 72 | var 73 | st: TFileStream; 74 | s: string; 75 | h, m, ss, ms: word; 76 | dt: Tdatetime; 77 | begin 78 | if fileexists(LogFile) then 79 | st := TFileStream.Create(LogFile, fmOpenReadWrite or fmShareDenyWrite) 80 | else 81 | st := TFileStream.Create(LogFile, fmCreate or fmShareDenyWrite); 82 | try 83 | st.Position := st.Size; 84 | dt := now; 85 | decodetime(dt, h, m, ss, ms); 86 | s := formatdatetime('yyyymmdd-hhnnss', dt) + format('.%.3d', [ms]) + ' ' + value; 87 | WriteStrToStream(st, s); 88 | finally 89 | st.free; 90 | end; 91 | end; 92 | 93 | class procedure TSynaDebug.HookStatus(Sender: TObject; Reason: THookSocketReason; const Value: string); 94 | var 95 | s: string; 96 | begin 97 | case Reason of 98 | HR_ResolvingBegin: 99 | s := 'HR_ResolvingBegin'; 100 | HR_ResolvingEnd: 101 | s := 'HR_ResolvingEnd'; 102 | HR_SocketCreate: 103 | s := 'HR_SocketCreate'; 104 | HR_SocketClose: 105 | s := 'HR_SocketClose'; 106 | HR_Bind: 107 | s := 'HR_Bind'; 108 | HR_Connect: 109 | s := 'HR_Connect'; 110 | HR_CanRead: 111 | s := 'HR_CanRead'; 112 | HR_CanWrite: 113 | s := 'HR_CanWrite'; 114 | HR_Listen: 115 | s := 'HR_Listen'; 116 | HR_Accept: 117 | s := 'HR_Accept'; 118 | HR_ReadCount: 119 | s := 'HR_ReadCount'; 120 | HR_WriteCount: 121 | s := 'HR_WriteCount'; 122 | HR_Wait: 123 | s := 'HR_Wait'; 124 | HR_Error: 125 | s := 'HR_Error'; 126 | else 127 | s := '-unknown-'; 128 | end; 129 | s := inttohex(integer(Sender), 8) + s + ': ' + value + CRLF; 130 | AppendToLog(s); 131 | end; 132 | 133 | class procedure TSynaDebug.HookMonitor(Sender: TObject; Writing: Boolean; const Buffer: TMemory; Len: Integer); 134 | var 135 | s, d: Ansistring; 136 | begin 137 | setlength(s, len); 138 | move(Buffer^, pointer(s)^, len); 139 | if writing then 140 | d := '-> ' 141 | else 142 | d := '<- '; 143 | s :=inttohex(integer(Sender), 8) + d + s + CRLF; 144 | AppendToLog(s); 145 | end; 146 | 147 | initialization 148 | begin 149 | Logfile := changefileext(paramstr(0), '.slog'); 150 | end; 151 | 152 | end. 153 | -------------------------------------------------------------------------------- /synapse/synafpc.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.001 | 3 | |==============================================================================| 4 | | Content: Utils for FreePascal compatibility | 5 | |==============================================================================| 6 | | Copyright (c)1999-2007, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2003-2007. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@exclude} 46 | 47 | {$IFDEF FPC} 48 | {$MODE DELPHI} 49 | {$ENDIF} 50 | {$H+} 51 | 52 | unit synafpc; 53 | 54 | interface 55 | 56 | uses 57 | {$IFDEF FPC} 58 | dynlibs, sysutils; 59 | {$ELSE} 60 | {$IFDEF WIN32} 61 | Windows; 62 | {$ELSE} 63 | SysUtils; 64 | {$ENDIF} 65 | {$ENDIF} 66 | 67 | {$IFDEF FPC} 68 | type 69 | TLibHandle = dynlibs.TLibHandle; 70 | 71 | function LoadLibrary(ModuleName: PChar): TLibHandle; 72 | function FreeLibrary(Module: TLibHandle): LongBool; 73 | function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; 74 | function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; 75 | {$ELSE} 76 | type 77 | {$IFDEF CIL} 78 | TLibHandle = Integer; 79 | {$ELSE} 80 | TLibHandle = HModule; 81 | {$ENDIF} 82 | {$IFDEF VER100} 83 | LongWord = DWord; 84 | {$ENDIF} 85 | {$ENDIF} 86 | 87 | procedure Sleep(milliseconds: Cardinal); 88 | 89 | 90 | implementation 91 | 92 | {==============================================================================} 93 | {$IFDEF FPC} 94 | function LoadLibrary(ModuleName: PChar): TLibHandle; 95 | begin 96 | Result := dynlibs.LoadLibrary(Modulename); 97 | end; 98 | 99 | function FreeLibrary(Module: TLibHandle): LongBool; 100 | begin 101 | Result := dynlibs.UnloadLibrary(Module); 102 | end; 103 | 104 | function GetProcAddress(Module: TLibHandle; Proc: PChar): Pointer; 105 | begin 106 | Result := dynlibs.GetProcedureAddress(Module, Proc); 107 | end; 108 | 109 | function GetModuleFileName(Module: TLibHandle; Buffer: PChar; BufLen: Integer): Integer; 110 | begin 111 | Result := 0; 112 | end; 113 | 114 | {$ELSE} 115 | {$ENDIF} 116 | 117 | procedure Sleep(milliseconds: Cardinal); 118 | begin 119 | {$IFDEF WIN32} 120 | {$IFDEF FPC} 121 | sysutils.sleep(milliseconds); 122 | {$ELSE} 123 | windows.sleep(milliseconds); 124 | {$ENDIF} 125 | {$ELSE} 126 | sysutils.sleep(milliseconds); 127 | {$ENDIF} 128 | 129 | end; 130 | 131 | end. 132 | -------------------------------------------------------------------------------- /synapse/synaicnv.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.001.000 | 3 | |==============================================================================| 4 | | Content: ICONV support for Win32, Linux and .NET | 5 | |==============================================================================| 6 | | Copyright (c)2004-2008, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2004-2008. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {$IFDEF FPC} 46 | {$MODE DELPHI} 47 | {$ENDIF} 48 | {$H+} 49 | 50 | {:@abstract(LibIconv support) 51 | 52 | This unit is Pascal interface to LibIconv library for charset translations. 53 | LibIconv is loaded dynamicly on-demand. If this library is not found in system, 54 | requested LibIconv function just return errorcode. 55 | } 56 | unit synaicnv; 57 | 58 | interface 59 | 60 | uses 61 | {$IFDEF CIL} 62 | System.Runtime.InteropServices, 63 | System.Text, 64 | {$ENDIF} 65 | synafpc, 66 | {$IFNDEF WIN32} 67 | {$IFNDEF FPC} 68 | Libc, 69 | {$ENDIF} 70 | SysUtils; 71 | {$ELSE} 72 | Windows; 73 | {$ENDIF} 74 | 75 | 76 | const 77 | {$IFNDEF WIN32} 78 | DLLIconvName = 'libiconv.so'; 79 | {$ELSE} 80 | DLLIconvName = 'iconv.dll'; 81 | {$ENDIF} 82 | 83 | type 84 | size_t = Cardinal; 85 | {$IFDEF CIL} 86 | iconv_t = IntPtr; 87 | {$ELSE} 88 | iconv_t = Pointer; 89 | {$ENDIF} 90 | argptr = iconv_t; 91 | 92 | var 93 | iconvLibHandle: TLibHandle = 0; 94 | 95 | function SynaIconvOpen(const tocode, fromcode: Ansistring): iconv_t; 96 | function SynaIconvOpenTranslit(const tocode, fromcode: Ansistring): iconv_t; 97 | function SynaIconvOpenIgnore(const tocode, fromcode: Ansistring): iconv_t; 98 | function SynaIconv(cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; 99 | function SynaIconvClose(var cd: iconv_t): integer; 100 | function SynaIconvCtl(cd: iconv_t; request: integer; argument: argptr): integer; 101 | 102 | function IsIconvloaded: Boolean; 103 | function InitIconvInterface: Boolean; 104 | function DestroyIconvInterface: Boolean; 105 | 106 | const 107 | ICONV_TRIVIALP = 0; // int *argument 108 | ICONV_GET_TRANSLITERATE = 1; // int *argument 109 | ICONV_SET_TRANSLITERATE = 2; // const int *argument 110 | ICONV_GET_DISCARD_ILSEQ = 3; // int *argument 111 | ICONV_SET_DISCARD_ILSEQ = 4; // const int *argument 112 | 113 | 114 | implementation 115 | 116 | uses SyncObjs; 117 | 118 | {$IFDEF CIL} 119 | [DllImport(DLLIconvName, CharSet = CharSet.Ansi, 120 | SetLastError = False, CallingConvention= CallingConvention.cdecl, 121 | EntryPoint = 'libiconv_open')] 122 | function _iconv_open(tocode: string; fromcode: string): iconv_t; external; 123 | 124 | [DllImport(DLLIconvName, CharSet = CharSet.Ansi, 125 | SetLastError = False, CallingConvention= CallingConvention.cdecl, 126 | EntryPoint = 'libiconv')] 127 | function _iconv(cd: iconv_t; var inbuf: IntPtr; var inbytesleft: size_t; 128 | var outbuf: IntPtr; var outbytesleft: size_t): size_t; external; 129 | 130 | [DllImport(DLLIconvName, CharSet = CharSet.Ansi, 131 | SetLastError = False, CallingConvention= CallingConvention.cdecl, 132 | EntryPoint = 'libiconv_close')] 133 | function _iconv_close(cd: iconv_t): integer; external; 134 | 135 | [DllImport(DLLIconvName, CharSet = CharSet.Ansi, 136 | SetLastError = False, CallingConvention= CallingConvention.cdecl, 137 | EntryPoint = 'libiconvctl')] 138 | function _iconvctl(cd: iconv_t; request: integer; argument: argptr): integer; external; 139 | 140 | {$ELSE} 141 | type 142 | Ticonv_open = function(tocode: pAnsichar; fromcode: pAnsichar): iconv_t; cdecl; 143 | Ticonv = function(cd: iconv_t; var inbuf: pointer; var inbytesleft: size_t; 144 | var outbuf: pointer; var outbytesleft: size_t): size_t; cdecl; 145 | Ticonv_close = function(cd: iconv_t): integer; cdecl; 146 | Ticonvctl = function(cd: iconv_t; request: integer; argument: argptr): integer; cdecl; 147 | var 148 | _iconv_open: Ticonv_open = nil; 149 | _iconv: Ticonv = nil; 150 | _iconv_close: Ticonv_close = nil; 151 | _iconvctl: Ticonvctl = nil; 152 | {$ENDIF} 153 | 154 | 155 | var 156 | IconvCS: TCriticalSection; 157 | Iconvloaded: boolean = false; 158 | 159 | function SynaIconvOpen (const tocode, fromcode: Ansistring): iconv_t; 160 | begin 161 | {$IFDEF CIL} 162 | try 163 | Result := _iconv_open(tocode, fromcode); 164 | except 165 | on Exception do 166 | Result := iconv_t(-1); 167 | end; 168 | {$ELSE} 169 | if InitIconvInterface and Assigned(_iconv_open) then 170 | Result := _iconv_open(PAnsiChar(tocode), PAnsiChar(fromcode)) 171 | else 172 | Result := iconv_t(-1); 173 | {$ENDIF} 174 | end; 175 | 176 | function SynaIconvOpenTranslit (const tocode, fromcode: Ansistring): iconv_t; 177 | begin 178 | Result := SynaIconvOpen(tocode + '//IGNORE//TRANSLIT', fromcode); 179 | end; 180 | 181 | function SynaIconvOpenIgnore (const tocode, fromcode: Ansistring): iconv_t; 182 | begin 183 | Result := SynaIconvOpen(tocode + '//IGNORE', fromcode); 184 | end; 185 | 186 | function SynaIconv (cd: iconv_t; inbuf: AnsiString; var outbuf: AnsiString): integer; 187 | var 188 | {$IFDEF CIL} 189 | ib, ob: IntPtr; 190 | ibsave, obsave: IntPtr; 191 | l: integer; 192 | {$ELSE} 193 | ib, ob: Pointer; 194 | {$ENDIF} 195 | ix, ox: size_t; 196 | begin 197 | {$IFDEF CIL} 198 | l := Length(inbuf) * 4; 199 | ibsave := IntPtr.Zero; 200 | obsave := IntPtr.Zero; 201 | try 202 | ibsave := Marshal.StringToHGlobalAnsi(inbuf); 203 | obsave := Marshal.AllocHGlobal(l); 204 | ib := ibsave; 205 | ob := obsave; 206 | ix := Length(inbuf); 207 | ox := l; 208 | _iconv(cd, ib, ix, ob, ox); 209 | Outbuf := Marshal.PtrToStringAnsi(obsave, l); 210 | setlength(Outbuf, l - ox); 211 | Result := Length(inbuf) - ix; 212 | finally 213 | Marshal.FreeCoTaskMem(ibsave); 214 | Marshal.FreeHGlobal(obsave); 215 | end; 216 | {$ELSE} 217 | if InitIconvInterface and Assigned(_iconv) then 218 | begin 219 | setlength(Outbuf, Length(inbuf) * 4); 220 | ib := Pointer(inbuf); 221 | ob := Pointer(Outbuf); 222 | ix := Length(inbuf); 223 | ox := Length(Outbuf); 224 | _iconv(cd, ib, ix, ob, ox); 225 | setlength(Outbuf, cardinal(Length(Outbuf)) - ox); 226 | Result := Cardinal(Length(inbuf)) - ix; 227 | end 228 | else 229 | begin 230 | Outbuf := ''; 231 | Result := 0; 232 | end; 233 | {$ENDIF} 234 | end; 235 | 236 | function SynaIconvClose(var cd: iconv_t): integer; 237 | begin 238 | if cd = iconv_t(-1) then 239 | begin 240 | Result := 0; 241 | Exit; 242 | end; 243 | {$IFDEF CIL} 244 | try; 245 | Result := _iconv_close(cd) 246 | except 247 | on Exception do 248 | Result := -1; 249 | end; 250 | cd := iconv_t(-1); 251 | {$ELSE} 252 | if InitIconvInterface and Assigned(_iconv_close) then 253 | Result := _iconv_close(cd) 254 | else 255 | Result := -1; 256 | cd := iconv_t(-1); 257 | {$ENDIF} 258 | end; 259 | 260 | function SynaIconvCtl (cd: iconv_t; request: integer; argument: argptr): integer; 261 | begin 262 | {$IFDEF CIL} 263 | Result := _iconvctl(cd, request, argument) 264 | {$ELSE} 265 | if InitIconvInterface and Assigned(_iconvctl) then 266 | Result := _iconvctl(cd, request, argument) 267 | else 268 | Result := 0; 269 | {$ENDIF} 270 | end; 271 | 272 | function InitIconvInterface: Boolean; 273 | begin 274 | IconvCS.Enter; 275 | try 276 | if not IsIconvloaded then 277 | begin 278 | {$IFDEF CIL} 279 | IconvLibHandle := 1; 280 | {$ELSE} 281 | IconvLibHandle := LoadLibrary(PChar(DLLIconvName)); 282 | {$ENDIF} 283 | if (IconvLibHandle <> 0) then 284 | begin 285 | {$IFNDEF CIL} 286 | _iconv_open := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_open'))); 287 | _iconv := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv'))); 288 | _iconv_close := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconv_close'))); 289 | _iconvctl := GetProcAddress(IconvLibHandle, PAnsiChar(AnsiString('libiconvctl'))); 290 | {$ENDIF} 291 | Result := True; 292 | Iconvloaded := True; 293 | end 294 | else 295 | begin 296 | //load failed! 297 | if IconvLibHandle <> 0 then 298 | begin 299 | {$IFNDEF CIL} 300 | FreeLibrary(IconvLibHandle); 301 | {$ENDIF} 302 | IconvLibHandle := 0; 303 | end; 304 | Result := False; 305 | end; 306 | end 307 | else 308 | //loaded before... 309 | Result := true; 310 | finally 311 | IconvCS.Leave; 312 | end; 313 | end; 314 | 315 | function DestroyIconvInterface: Boolean; 316 | begin 317 | IconvCS.Enter; 318 | try 319 | Iconvloaded := false; 320 | if IconvLibHandle <> 0 then 321 | begin 322 | {$IFNDEF CIL} 323 | FreeLibrary(IconvLibHandle); 324 | {$ENDIF} 325 | IconvLibHandle := 0; 326 | end; 327 | {$IFNDEF CIL} 328 | _iconv_open := nil; 329 | _iconv := nil; 330 | _iconv_close := nil; 331 | _iconvctl := nil; 332 | {$ENDIF} 333 | finally 334 | IconvCS.Leave; 335 | end; 336 | Result := True; 337 | end; 338 | 339 | function IsIconvloaded: Boolean; 340 | begin 341 | Result := IconvLoaded; 342 | end; 343 | 344 | initialization 345 | begin 346 | IconvCS:= TCriticalSection.Create; 347 | end; 348 | 349 | finalization 350 | begin 351 | {$IFNDEF CIL} 352 | DestroyIconvInterface; 353 | {$ENDIF} 354 | IconvCS.Free; 355 | end; 356 | 357 | end. 358 | -------------------------------------------------------------------------------- /synapse/synaip.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.002.000 | 3 | |==============================================================================| 4 | | Content: IP address support procedures and functions | 5 | |==============================================================================| 6 | | Copyright (c)2006-2009, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c) 2006-2008. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract(IP adress support procedures and functions)} 46 | 47 | {$IFDEF FPC} 48 | {$MODE DELPHI} 49 | {$ENDIF} 50 | {$Q-} 51 | {$R-} 52 | {$H+} 53 | 54 | unit synaip; 55 | 56 | interface 57 | 58 | uses 59 | SysUtils, SynaUtil; 60 | 61 | type 62 | {:binary form of IPv6 adress (for string conversion routines)} 63 | TIp6Bytes = array [0..15] of Byte; 64 | {:binary form of IPv6 adress (for string conversion routines)} 65 | TIp6Words = array [0..7] of Word; 66 | 67 | {:Returns @TRUE, if "Value" is a valid IPv4 address. Cannot be a symbolic Name!} 68 | function IsIP(const Value: string): Boolean; 69 | 70 | {:Returns @TRUE, if "Value" is a valid IPv6 address. Cannot be a symbolic Name!} 71 | function IsIP6(const Value: string): Boolean; 72 | 73 | {:Returns a string with the "Host" ip address converted to binary form.} 74 | function IPToID(Host: string): Ansistring; 75 | 76 | {:Convert IPv6 address from their string form to binary byte array.} 77 | function StrToIp6(value: string): TIp6Bytes; 78 | 79 | {:Convert IPv6 address from binary byte array to string form.} 80 | function Ip6ToStr(value: TIp6Bytes): string; 81 | 82 | {:Convert IPv4 address from their string form to binary.} 83 | function StrToIp(value: string): integer; 84 | 85 | {:Convert IPv4 address from binary to string form.} 86 | function IpToStr(value: integer): string; 87 | 88 | {:Convert IPv4 address to reverse form.} 89 | function ReverseIP(Value: AnsiString): AnsiString; 90 | 91 | {:Convert IPv6 address to reverse form.} 92 | function ReverseIP6(Value: AnsiString): AnsiString; 93 | 94 | {:Expand short form of IPv6 address to long form.} 95 | function ExpandIP6(Value: AnsiString): AnsiString; 96 | 97 | 98 | implementation 99 | 100 | {==============================================================================} 101 | 102 | function IsIP(const Value: string): Boolean; 103 | var 104 | TempIP: string; 105 | function ByteIsOk(const Value: string): Boolean; 106 | var 107 | x, n: integer; 108 | begin 109 | x := StrToIntDef(Value, -1); 110 | Result := (x >= 0) and (x < 256); 111 | // X may be in correct range, but value still may not be correct value! 112 | // i.e. "$80" 113 | if Result then 114 | for n := 1 to length(Value) do 115 | if not (Value[n] in ['0'..'9']) then 116 | begin 117 | Result := False; 118 | Break; 119 | end; 120 | end; 121 | begin 122 | TempIP := Value; 123 | Result := False; 124 | if not ByteIsOk(Fetch(TempIP, '.')) then 125 | Exit; 126 | if not ByteIsOk(Fetch(TempIP, '.')) then 127 | Exit; 128 | if not ByteIsOk(Fetch(TempIP, '.')) then 129 | Exit; 130 | if ByteIsOk(TempIP) then 131 | Result := True; 132 | end; 133 | 134 | {==============================================================================} 135 | 136 | function IsIP6(const Value: string): Boolean; 137 | var 138 | TempIP: string; 139 | s,t: string; 140 | x: integer; 141 | partcount: integer; 142 | zerocount: integer; 143 | First: Boolean; 144 | begin 145 | TempIP := Value; 146 | Result := False; 147 | if Value = '::' then 148 | begin 149 | Result := True; 150 | Exit; 151 | end; 152 | partcount := 0; 153 | zerocount := 0; 154 | First := True; 155 | while tempIP <> '' do 156 | begin 157 | s := fetch(TempIP, ':'); 158 | if not(First) and (s = '') then 159 | Inc(zerocount); 160 | First := False; 161 | if zerocount > 1 then 162 | break; 163 | Inc(partCount); 164 | if s = '' then 165 | Continue; 166 | if partCount > 8 then 167 | break; 168 | if tempIP = '' then 169 | begin 170 | t := SeparateRight(s, '%'); 171 | s := SeparateLeft(s, '%'); 172 | x := StrToIntDef('$' + t, -1); 173 | if (x < 0) or (x > $ffff) then 174 | break; 175 | end; 176 | x := StrToIntDef('$' + s, -1); 177 | if (x < 0) or (x > $ffff) then 178 | break; 179 | if tempIP = '' then 180 | if not((PartCount = 1) and (ZeroCount = 0)) then 181 | Result := True; 182 | end; 183 | end; 184 | 185 | {==============================================================================} 186 | function IPToID(Host: string): Ansistring; 187 | var 188 | s: string; 189 | i, x: Integer; 190 | begin 191 | Result := ''; 192 | for x := 0 to 3 do 193 | begin 194 | s := Fetch(Host, '.'); 195 | i := StrToIntDef(s, 0); 196 | Result := Result + Chr(i); 197 | end; 198 | end; 199 | 200 | {==============================================================================} 201 | 202 | function StrToIp(value: string): integer; 203 | var 204 | s: string; 205 | i, x: Integer; 206 | begin 207 | Result := 0; 208 | for x := 0 to 3 do 209 | begin 210 | s := Fetch(value, '.'); 211 | i := StrToIntDef(s, 0); 212 | Result := (256 * Result) + i; 213 | end; 214 | end; 215 | 216 | {==============================================================================} 217 | 218 | function IpToStr(value: integer): string; 219 | var 220 | x1, x2: word; 221 | y1, y2: byte; 222 | begin 223 | Result := ''; 224 | x1 := value shr 16; 225 | x2 := value and $FFFF; 226 | y1 := x1 div $100; 227 | y2 := x1 mod $100; 228 | Result := inttostr(y1) + '.' + inttostr(y2) + '.'; 229 | y1 := x2 div $100; 230 | y2 := x2 mod $100; 231 | Result := Result + inttostr(y1) + '.' + inttostr(y2); 232 | end; 233 | 234 | {==============================================================================} 235 | 236 | function ExpandIP6(Value: AnsiString): AnsiString; 237 | var 238 | n: integer; 239 | s: ansistring; 240 | x: integer; 241 | begin 242 | Result := ''; 243 | if value = '' then 244 | exit; 245 | x := countofchar(value, ':'); 246 | if x > 7 then 247 | exit; 248 | if value[1] = ':' then 249 | value := '0' + value; 250 | if value[length(value)] = ':' then 251 | value := value + '0'; 252 | x := 8 - x; 253 | s := ''; 254 | for n := 1 to x do 255 | s := s + ':0'; 256 | s := s + ':'; 257 | Result := replacestring(value, '::', s); 258 | end; 259 | {==============================================================================} 260 | 261 | function StrToIp6(Value: string): TIp6Bytes; 262 | var 263 | IPv6: TIp6Words; 264 | Index: Integer; 265 | n: integer; 266 | b1, b2: byte; 267 | s: string; 268 | x: integer; 269 | begin 270 | for n := 0 to 15 do 271 | Result[n] := 0; 272 | for n := 0 to 7 do 273 | Ipv6[n] := 0; 274 | Index := 0; 275 | Value := ExpandIP6(value); 276 | if value = '' then 277 | exit; 278 | while Value <> '' do 279 | begin 280 | if Index > 7 then 281 | Exit; 282 | s := fetch(value, ':'); 283 | if s = '@' then 284 | break; 285 | if s = '' then 286 | begin 287 | IPv6[Index] := 0; 288 | end 289 | else 290 | begin 291 | x := StrToIntDef('$' + s, -1); 292 | if (x > 65535) or (x < 0) then 293 | Exit; 294 | IPv6[Index] := x; 295 | end; 296 | Inc(Index); 297 | end; 298 | for n := 0 to 7 do 299 | begin 300 | b1 := ipv6[n] div 256; 301 | b2 := ipv6[n] mod 256; 302 | Result[n * 2] := b1; 303 | Result[(n * 2) + 1] := b2; 304 | end; 305 | end; 306 | 307 | {==============================================================================} 308 | //based on routine by the Free Pascal development team 309 | function Ip6ToStr(value: TIp6Bytes): string; 310 | var 311 | i, x: byte; 312 | zr1,zr2: set of byte; 313 | zc1,zc2: byte; 314 | have_skipped: boolean; 315 | ip6w: TIp6words; 316 | begin 317 | zr1 := []; 318 | zr2 := []; 319 | zc1 := 0; 320 | zc2 := 0; 321 | for i := 0 to 7 do 322 | begin 323 | x := i * 2; 324 | ip6w[i] := value[x] * 256 + value[x + 1]; 325 | if ip6w[i] = 0 then 326 | begin 327 | include(zr2, i); 328 | inc(zc2); 329 | end 330 | else 331 | begin 332 | if zc1 < zc2 then 333 | begin 334 | zc1 := zc2; 335 | zr1 := zr2; 336 | zc2 := 0; 337 | zr2 := []; 338 | end; 339 | end; 340 | end; 341 | if zc1 < zc2 then 342 | begin 343 | zr1 := zr2; 344 | end; 345 | SetLength(Result, 8*5-1); 346 | SetLength(Result, 0); 347 | have_skipped := false; 348 | for i := 0 to 7 do 349 | begin 350 | if not(i in zr1) then 351 | begin 352 | if have_skipped then 353 | begin 354 | if Result = '' then 355 | Result := '::' 356 | else 357 | Result := Result + ':'; 358 | have_skipped := false; 359 | end; 360 | Result := Result + IntToHex(Ip6w[i], 1) + ':'; 361 | end 362 | else 363 | begin 364 | have_skipped := true; 365 | end; 366 | end; 367 | if have_skipped then 368 | if Result = '' then 369 | Result := '::0' 370 | else 371 | Result := Result + ':'; 372 | 373 | if Result = '' then 374 | Result := '::0'; 375 | if not (7 in zr1) then 376 | SetLength(Result, Length(Result)-1); 377 | Result := LowerCase(result); 378 | end; 379 | 380 | {==============================================================================} 381 | function ReverseIP(Value: AnsiString): AnsiString; 382 | var 383 | x: Integer; 384 | begin 385 | Result := ''; 386 | repeat 387 | x := LastDelimiter('.', Value); 388 | Result := Result + '.' + Copy(Value, x + 1, Length(Value) - x); 389 | Delete(Value, x, Length(Value) - x + 1); 390 | until x < 1; 391 | if Length(Result) > 0 then 392 | if Result[1] = '.' then 393 | Delete(Result, 1, 1); 394 | end; 395 | 396 | {==============================================================================} 397 | function ReverseIP6(Value: AnsiString): AnsiString; 398 | var 399 | ip6: TIp6bytes; 400 | n: integer; 401 | x, y: integer; 402 | begin 403 | ip6 := StrToIP6(Value); 404 | x := ip6[15] div 16; 405 | y := ip6[15] mod 16; 406 | Result := IntToHex(y, 1) + '.' + IntToHex(x, 1); 407 | for n := 14 downto 0 do 408 | begin 409 | x := ip6[n] div 16; 410 | y := ip6[n] mod 16; 411 | Result := Result + '.' + IntToHex(y, 1) + '.' + IntToHex(x, 1); 412 | end; 413 | end; 414 | 415 | {==============================================================================} 416 | end. 417 | -------------------------------------------------------------------------------- /synapse/synamisc.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.003.000 | 3 | |==============================================================================| 4 | | Content: misc. procedures and functions | 5 | |==============================================================================| 6 | | Copyright (c)1999-2008, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c) 2002-2008. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract(Misc. network based utilities)} 46 | 47 | {$IFDEF FPC} 48 | {$MODE DELPHI} 49 | {$ENDIF} 50 | {$Q-} 51 | {$H+} 52 | 53 | unit synamisc; 54 | 55 | interface 56 | 57 | {$IFDEF VER125} 58 | {$DEFINE BCB} 59 | {$ENDIF} 60 | {$IFDEF BCB} 61 | {$ObjExportAll On} 62 | {$HPPEMIT '#pragma comment( lib , "wininet.lib" )'} 63 | {$ENDIF} 64 | 65 | uses 66 | synautil, blcksock, SysUtils, Classes, 67 | {$IFDEF LINUX} 68 | Libc; 69 | {$ELSE} 70 | Windows; 71 | {$ENDIF} 72 | 73 | Type 74 | {:@abstract(This record contains information about proxy setting.)} 75 | TProxySetting = record 76 | Host: string; 77 | Port: string; 78 | Bypass: string; 79 | end; 80 | 81 | {:By this function you can turn-on computer on network, if this computer 82 | supporting Wake-on-lan feature. You need MAC number (network card indentifier) 83 | of computer for turn-on. You can also assign target IP addres. If you not 84 | specify it, then is used broadcast for delivery magic wake-on packet. However 85 | broadcasts workinh only on your local network. When you need to wake-up 86 | computer on another network, you must specify any existing IP addres on same 87 | network segment as targeting computer.} 88 | procedure WakeOnLan(MAC, IP: string); 89 | 90 | {:Autodetect current DNS servers used by system. If is defined more then one DNS 91 | server, then result is comma-delimited.} 92 | function GetDNS: string; 93 | 94 | {:Autodetect InternetExplorer proxy setting for given protocol. This function 95 | working only on windows!} 96 | function GetIEProxy(protocol: string): TProxySetting; 97 | 98 | {:Return all known IP addresses on local system. Addresses are divided by comma.} 99 | function GetLocalIPs: string; 100 | 101 | implementation 102 | 103 | {==============================================================================} 104 | procedure WakeOnLan(MAC, IP: string); 105 | var 106 | sock: TUDPBlockSocket; 107 | HexMac: Ansistring; 108 | data: Ansistring; 109 | n: integer; 110 | b: Byte; 111 | begin 112 | if MAC <> '' then 113 | begin 114 | MAC := ReplaceString(MAC, '-', ''); 115 | MAC := ReplaceString(MAC, ':', ''); 116 | if Length(MAC) < 12 then 117 | Exit; 118 | HexMac := ''; 119 | for n := 0 to 5 do 120 | begin 121 | b := StrToIntDef('$' + MAC[n * 2 + 1] + MAC[n * 2 + 2], 0); 122 | HexMac := HexMac + char(b); 123 | end; 124 | if IP = '' then 125 | IP := cBroadcast; 126 | sock := TUDPBlockSocket.Create; 127 | try 128 | sock.CreateSocket; 129 | sock.EnableBroadcast(true); 130 | sock.Connect(IP, '9'); 131 | data := #$FF + #$FF + #$FF + #$FF + #$FF + #$FF; 132 | for n := 1 to 16 do 133 | data := data + HexMac; 134 | sock.SendString(data); 135 | finally 136 | sock.Free; 137 | end; 138 | end; 139 | end; 140 | 141 | {==============================================================================} 142 | 143 | {$IFNDEF LINUX} 144 | function GetDNSbyIpHlp: string; 145 | type 146 | PTIP_ADDRESS_STRING = ^TIP_ADDRESS_STRING; 147 | TIP_ADDRESS_STRING = array[0..15] of Ansichar; 148 | PTIP_ADDR_STRING = ^TIP_ADDR_STRING; 149 | TIP_ADDR_STRING = packed record 150 | Next: PTIP_ADDR_STRING; 151 | IpAddress: TIP_ADDRESS_STRING; 152 | IpMask: TIP_ADDRESS_STRING; 153 | Context: DWORD; 154 | end; 155 | PTFixedInfo = ^TFixedInfo; 156 | TFixedInfo = packed record 157 | HostName: array[1..128 + 4] of Ansichar; 158 | DomainName: array[1..128 + 4] of Ansichar; 159 | CurrentDNSServer: PTIP_ADDR_STRING; 160 | DNSServerList: TIP_ADDR_STRING; 161 | NodeType: UINT; 162 | ScopeID: array[1..256 + 4] of Ansichar; 163 | EnableRouting: UINT; 164 | EnableProxy: UINT; 165 | EnableDNS: UINT; 166 | end; 167 | const 168 | IpHlpDLL = 'IPHLPAPI.DLL'; 169 | var 170 | IpHlpModule: THandle; 171 | FixedInfo: PTFixedInfo; 172 | InfoSize: Longint; 173 | PDnsServer: PTIP_ADDR_STRING; 174 | err: integer; 175 | GetNetworkParams: function(FixedInfo: PTFixedInfo; pOutPutLen: PULONG): DWORD; stdcall; 176 | begin 177 | InfoSize := 0; 178 | Result := '...'; 179 | IpHlpModule := LoadLibrary(IpHlpDLL); 180 | if IpHlpModule = 0 then 181 | exit; 182 | try 183 | GetNetworkParams := GetProcAddress(IpHlpModule,PAnsiChar(AnsiString('GetNetworkParams'))); 184 | if @GetNetworkParams = nil then 185 | Exit; 186 | err := GetNetworkParams(Nil, @InfoSize); 187 | if err <> ERROR_BUFFER_OVERFLOW then 188 | Exit; 189 | Result := ''; 190 | GetMem (FixedInfo, InfoSize); 191 | try 192 | err := GetNetworkParams(FixedInfo, @InfoSize); 193 | if err <> ERROR_SUCCESS then 194 | exit; 195 | with FixedInfo^ do 196 | begin 197 | Result := DnsServerList.IpAddress; 198 | PDnsServer := DnsServerList.Next; 199 | while PDnsServer <> Nil do 200 | begin 201 | if Result <> '' then 202 | Result := Result + ','; 203 | Result := Result + PDnsServer^.IPAddress; 204 | PDnsServer := PDnsServer.Next; 205 | end; 206 | end; 207 | finally 208 | FreeMem(FixedInfo); 209 | end; 210 | finally 211 | FreeLibrary(IpHlpModule); 212 | end; 213 | end; 214 | 215 | function ReadReg(SubKey, Vn: PChar): string; 216 | var 217 | OpenKey: HKEY; 218 | DataType, DataSize: integer; 219 | Temp: array [0..2048] of char; 220 | begin 221 | Result := ''; 222 | if RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, REG_OPTION_NON_VOLATILE, 223 | KEY_READ, OpenKey) = ERROR_SUCCESS then 224 | begin 225 | DataType := REG_SZ; 226 | DataSize := SizeOf(Temp); 227 | if RegQueryValueEx(OpenKey, Vn, nil, @DataType, @Temp, @DataSize) = ERROR_SUCCESS then 228 | SetString(Result, Temp, DataSize div SizeOf(Char) - 1); 229 | RegCloseKey(OpenKey); 230 | end; 231 | end ; 232 | {$ENDIF} 233 | 234 | function GetDNS: string; 235 | {$IFDEF LINUX} 236 | var 237 | l: TStringList; 238 | n: integer; 239 | begin 240 | Result := ''; 241 | l := TStringList.Create; 242 | try 243 | l.LoadFromFile('/etc/resolv.conf'); 244 | for n := 0 to l.Count - 1 do 245 | if Pos('NAMESERVER', uppercase(l[n])) = 1 then 246 | begin 247 | if Result <> '' then 248 | Result := Result + ','; 249 | Result := Result + SeparateRight(l[n], ' '); 250 | end; 251 | finally 252 | l.Free; 253 | end; 254 | end; 255 | {$ELSE} 256 | const 257 | NTdyn = 'System\CurrentControlSet\Services\Tcpip\Parameters\Temporary'; 258 | NTfix = 'System\CurrentControlSet\Services\Tcpip\Parameters'; 259 | W9xfix = 'System\CurrentControlSet\Services\MSTCP'; 260 | begin 261 | Result := GetDNSbyIpHlp; 262 | if Result = '...' then 263 | begin 264 | if Win32Platform = VER_PLATFORM_WIN32_NT then 265 | begin 266 | Result := ReadReg(NTdyn, 'NameServer'); 267 | if result = '' then 268 | Result := ReadReg(NTfix, 'NameServer'); 269 | if result = '' then 270 | Result := ReadReg(NTfix, 'DhcpNameServer'); 271 | end 272 | else 273 | Result := ReadReg(W9xfix, 'NameServer'); 274 | Result := ReplaceString(trim(Result), ' ', ','); 275 | end; 276 | end; 277 | {$ENDIF} 278 | 279 | {==============================================================================} 280 | 281 | function GetIEProxy(protocol: string): TProxySetting; 282 | {$IFDEF LINUX} 283 | begin 284 | Result.Host := ''; 285 | Result.Port := ''; 286 | Result.Bypass := ''; 287 | end; 288 | {$ELSE} 289 | type 290 | PInternetProxyInfo = ^TInternetProxyInfo; 291 | TInternetProxyInfo = packed record 292 | dwAccessType: DWORD; 293 | lpszProxy: LPCSTR; 294 | lpszProxyBypass: LPCSTR; 295 | end; 296 | const 297 | INTERNET_OPTION_PROXY = 38; 298 | INTERNET_OPEN_TYPE_PROXY = 3; 299 | WininetDLL = 'WININET.DLL'; 300 | var 301 | WininetModule: THandle; 302 | ProxyInfo: PInternetProxyInfo; 303 | Err: Boolean; 304 | Len: DWORD; 305 | Proxy: string; 306 | DefProxy: string; 307 | ProxyList: TStringList; 308 | n: integer; 309 | InternetQueryOption: function (hInet: Pointer; dwOption: DWORD; 310 | lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall; 311 | begin 312 | Result.Host := ''; 313 | Result.Port := ''; 314 | Result.Bypass := ''; 315 | WininetModule := LoadLibrary(WininetDLL); 316 | if WininetModule = 0 then 317 | exit; 318 | try 319 | InternetQueryOption := GetProcAddress(WininetModule,PAnsiChar(AnsiString('InternetQueryOptionA'))); 320 | if @InternetQueryOption = nil then 321 | Exit; 322 | 323 | if protocol = '' then 324 | protocol := 'http'; 325 | Len := 4096; 326 | GetMem(ProxyInfo, Len); 327 | ProxyList := TStringList.Create; 328 | try 329 | Err := InternetQueryOption(nil, INTERNET_OPTION_PROXY, ProxyInfo, Len); 330 | if Err then 331 | if ProxyInfo^.dwAccessType = INTERNET_OPEN_TYPE_PROXY then 332 | begin 333 | ProxyList.CommaText := ReplaceString(ProxyInfo^.lpszProxy, ' ', ','); 334 | Proxy := ''; 335 | DefProxy := ''; 336 | for n := 0 to ProxyList.Count -1 do 337 | begin 338 | if Pos(lowercase(protocol) + '=', lowercase(ProxyList[n])) = 1 then 339 | begin 340 | Proxy := SeparateRight(ProxyList[n], '='); 341 | break; 342 | end; 343 | if Pos('=', ProxyList[n]) < 1 then 344 | DefProxy := ProxyList[n]; 345 | end; 346 | if Proxy = '' then 347 | Proxy := DefProxy; 348 | if Proxy <> '' then 349 | begin 350 | Result.Host := Trim(SeparateLeft(Proxy, ':')); 351 | Result.Port := Trim(SeparateRight(Proxy, ':')); 352 | end; 353 | Result.Bypass := ReplaceString(ProxyInfo^.lpszProxyBypass, ' ', ','); 354 | end; 355 | finally 356 | ProxyList.Free; 357 | FreeMem(ProxyInfo); 358 | end; 359 | finally 360 | FreeLibrary(WininetModule); 361 | end; 362 | end; 363 | {$ENDIF} 364 | 365 | {==============================================================================} 366 | 367 | function GetLocalIPs: string; 368 | var 369 | TcpSock: TTCPBlockSocket; 370 | ipList: TStringList; 371 | begin 372 | Result := ''; 373 | ipList := TStringList.Create; 374 | try 375 | TcpSock := TTCPBlockSocket.create; 376 | try 377 | TcpSock.ResolveNameToIP(TcpSock.LocalName, ipList); 378 | Result := ipList.CommaText; 379 | finally 380 | TcpSock.Free; 381 | end; 382 | finally 383 | ipList.Free; 384 | end; 385 | end; 386 | 387 | {==============================================================================} 388 | 389 | end. 390 | -------------------------------------------------------------------------------- /synapse/synautil.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/crossrw/mqttClient/7f392ca2d692b119ecfb35c6b034f59c6640617d/synapse/synautil.pas -------------------------------------------------------------------------------- /synapse/synsock.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 005.001.000 | 3 | |==============================================================================| 4 | | Content: Socket Independent Platform Layer | 5 | |==============================================================================| 6 | | Copyright (c)1999-2003, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2001-2003. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@exclude} 46 | 47 | unit synsock; 48 | 49 | {$MINENUMSIZE 4} 50 | 51 | {$IFDEF CIL} 52 | {$I ssdotnet.pas} 53 | {$ENDIF} 54 | 55 | {$IFDEF WIN32} 56 | {$I sswin32.pas} 57 | {$ELSE} 58 | {$IFDEF FPC} 59 | {$I ssfpc.pas} 60 | {$ELSE} 61 | {$I sslinux.pas} 62 | {$ENDIF} 63 | {$ENDIF} 64 | 65 | 66 | end. 67 | 68 | -------------------------------------------------------------------------------- /synapse/tlntsend.pas: -------------------------------------------------------------------------------- 1 | {==============================================================================| 2 | | Project : Ararat Synapse | 001.003.000 | 3 | |==============================================================================| 4 | | Content: TELNET and SSH2 client | 5 | |==============================================================================| 6 | | Copyright (c)1999-2008, Lukas Gebauer | 7 | | All rights reserved. | 8 | | | 9 | | Redistribution and use in source and binary forms, with or without | 10 | | modification, are permitted provided that the following conditions are met: | 11 | | | 12 | | Redistributions of source code must retain the above copyright notice, this | 13 | | list of conditions and the following disclaimer. | 14 | | | 15 | | Redistributions in binary form must reproduce the above copyright notice, | 16 | | this list of conditions and the following disclaimer in the documentation | 17 | | and/or other materials provided with the distribution. | 18 | | | 19 | | Neither the name of Lukas Gebauer nor the names of its contributors may | 20 | | be used to endorse or promote products derived from this software without | 21 | | specific prior written permission. | 22 | | | 23 | | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" | 24 | | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE | 25 | | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE | 26 | | ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR | 27 | | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL | 28 | | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR | 29 | | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER | 30 | | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT | 31 | | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY | 32 | | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH | 33 | | DAMAGE. | 34 | |==============================================================================| 35 | | The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).| 36 | | Portions created by Lukas Gebauer are Copyright (c)2002-2008. | 37 | | All Rights Reserved. | 38 | |==============================================================================| 39 | | Contributor(s): | 40 | |==============================================================================| 41 | | History: see HISTORY.HTM from distribution package | 42 | | (Found at URL: http://www.ararat.cz/synapse/) | 43 | |==============================================================================} 44 | 45 | {:@abstract(Telnet script client) 46 | 47 | Used RFC: RFC-854 48 | } 49 | 50 | {$IFDEF FPC} 51 | {$MODE DELPHI} 52 | {$ENDIF} 53 | {$H+} 54 | 55 | unit tlntsend; 56 | 57 | interface 58 | 59 | uses 60 | SysUtils, Classes, 61 | blcksock, synautil; 62 | 63 | const 64 | cTelnetProtocol = '23'; 65 | cSSHProtocol = '22'; 66 | 67 | TLNT_EOR = #239; 68 | TLNT_SE = #240; 69 | TLNT_NOP = #241; 70 | TLNT_DATA_MARK = #242; 71 | TLNT_BREAK = #243; 72 | TLNT_IP = #244; 73 | TLNT_AO = #245; 74 | TLNT_AYT = #246; 75 | TLNT_EC = #247; 76 | TLNT_EL = #248; 77 | TLNT_GA = #249; 78 | TLNT_SB = #250; 79 | TLNT_WILL = #251; 80 | TLNT_WONT = #252; 81 | TLNT_DO = #253; 82 | TLNT_DONT = #254; 83 | TLNT_IAC = #255; 84 | 85 | type 86 | {:@abstract(State of telnet protocol). Used internaly by TTelnetSend.} 87 | TTelnetState =(tsDATA, tsIAC, tsIAC_SB, tsIAC_WILL, tsIAC_DO, tsIAC_WONT, 88 | tsIAC_DONT, tsIAC_SBIAC, tsIAC_SBDATA, tsSBDATA_IAC); 89 | 90 | {:@abstract(Class with implementation of Telnet/SSH script client.) 91 | 92 | Note: Are you missing properties for specify server address and port? Look to 93 | parent @link(TSynaClient) too!} 94 | TTelnetSend = class(TSynaClient) 95 | private 96 | FSock: TTCPBlockSocket; 97 | FBuffer: Ansistring; 98 | FState: TTelnetState; 99 | FSessionLog: Ansistring; 100 | FSubNeg: Ansistring; 101 | FSubType: Ansichar; 102 | FTermType: Ansistring; 103 | function Connect: Boolean; 104 | function Negotiate(const Buf: Ansistring): Ansistring; 105 | procedure FilterHook(Sender: TObject; var Value: AnsiString); 106 | public 107 | constructor Create; 108 | destructor Destroy; override; 109 | 110 | {:Connects to Telnet server.} 111 | function Login: Boolean; 112 | 113 | {:Connects to SSH2 server and login by Username and Password properties. 114 | 115 | You must use some of SSL plugins with SSH support. For exammple CryptLib.} 116 | function SSHLogin: Boolean; 117 | 118 | {:Logout from telnet server.} 119 | procedure Logout; 120 | 121 | {:Send this data to telnet server.} 122 | procedure Send(const Value: string); 123 | 124 | {:Reading data from telnet server until Value is readed. If it is not readed 125 | until timeout, result is @false. Otherwise result is @true.} 126 | function WaitFor(const Value: string): Boolean; 127 | 128 | {:Read data terminated by terminator from telnet server.} 129 | function RecvTerminated(const Terminator: string): string; 130 | 131 | {:Read string from telnet server.} 132 | function RecvString: string; 133 | published 134 | {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.} 135 | property Sock: TTCPBlockSocket read FSock; 136 | 137 | {:all readed datas in this session (from connect) is stored in this large 138 | string.} 139 | property SessionLog: Ansistring read FSessionLog write FSessionLog; 140 | 141 | {:Terminal type indentification. By default is 'SYNAPSE'.} 142 | property TermType: Ansistring read FTermType write FTermType; 143 | end; 144 | 145 | implementation 146 | 147 | constructor TTelnetSend.Create; 148 | begin 149 | inherited Create; 150 | FSock := TTCPBlockSocket.Create; 151 | FSock.OnReadFilter := FilterHook; 152 | FTimeout := 60000; 153 | FTargetPort := cTelnetProtocol; 154 | FSubNeg := ''; 155 | FSubType := #0; 156 | FTermType := 'SYNAPSE'; 157 | end; 158 | 159 | destructor TTelnetSend.Destroy; 160 | begin 161 | FSock.Free; 162 | inherited Destroy; 163 | end; 164 | 165 | function TTelnetSend.Connect: Boolean; 166 | begin 167 | // Do not call this function! It is calling by LOGIN method! 168 | FBuffer := ''; 169 | FSessionLog := ''; 170 | FState := tsDATA; 171 | FSock.CloseSocket; 172 | FSock.LineBuffer := ''; 173 | FSock.Bind(FIPInterface, cAnyPort); 174 | FSock.Connect(FTargetHost, FTargetPort); 175 | Result := FSock.LastError = 0; 176 | end; 177 | 178 | function TTelnetSend.RecvTerminated(const Terminator: string): string; 179 | begin 180 | Result := FSock.RecvTerminated(FTimeout, Terminator); 181 | end; 182 | 183 | function TTelnetSend.RecvString: string; 184 | begin 185 | Result := FSock.RecvTerminated(FTimeout, CRLF); 186 | end; 187 | 188 | function TTelnetSend.WaitFor(const Value: string): Boolean; 189 | begin 190 | Result := FSock.RecvTerminated(FTimeout, Value) <> ''; 191 | end; 192 | 193 | procedure TTelnetSend.FilterHook(Sender: TObject; var Value: AnsiString); 194 | begin 195 | Value := Negotiate(Value); 196 | FSessionLog := FSessionLog + Value; 197 | end; 198 | 199 | function TTelnetSend.Negotiate(const Buf: Ansistring): Ansistring; 200 | var 201 | n: integer; 202 | c: Ansichar; 203 | Reply: Ansistring; 204 | SubReply: Ansistring; 205 | begin 206 | Result := ''; 207 | for n := 1 to Length(Buf) do 208 | begin 209 | c := Buf[n]; 210 | Reply := ''; 211 | case FState of 212 | tsData: 213 | if c = TLNT_IAC then 214 | FState := tsIAC 215 | else 216 | Result := Result + c; 217 | 218 | tsIAC: 219 | case c of 220 | TLNT_IAC: 221 | begin 222 | FState := tsData; 223 | Result := Result + TLNT_IAC; 224 | end; 225 | TLNT_WILL: 226 | FState := tsIAC_WILL; 227 | TLNT_WONT: 228 | FState := tsIAC_WONT; 229 | TLNT_DONT: 230 | FState := tsIAC_DONT; 231 | TLNT_DO: 232 | FState := tsIAC_DO; 233 | TLNT_EOR: 234 | FState := tsDATA; 235 | TLNT_SB: 236 | begin 237 | FState := tsIAC_SB; 238 | FSubType := #0; 239 | FSubNeg := ''; 240 | end; 241 | else 242 | FState := tsData; 243 | end; 244 | 245 | tsIAC_WILL: 246 | begin 247 | case c of 248 | #3: //suppress GA 249 | Reply := TLNT_DO; 250 | else 251 | Reply := TLNT_DONT; 252 | end; 253 | FState := tsData; 254 | end; 255 | 256 | tsIAC_WONT: 257 | begin 258 | Reply := TLNT_DONT; 259 | FState := tsData; 260 | end; 261 | 262 | tsIAC_DO: 263 | begin 264 | case c of 265 | #24: //termtype 266 | Reply := TLNT_WILL; 267 | else 268 | Reply := TLNT_WONT; 269 | end; 270 | FState := tsData; 271 | end; 272 | 273 | tsIAC_DONT: 274 | begin 275 | Reply := TLNT_WONT; 276 | FState := tsData; 277 | end; 278 | 279 | tsIAC_SB: 280 | begin 281 | FSubType := c; 282 | FState := tsIAC_SBDATA; 283 | end; 284 | 285 | tsIAC_SBDATA: 286 | begin 287 | if c = TLNT_IAC then 288 | FState := tsSBDATA_IAC 289 | else 290 | FSubNeg := FSubNeg + c; 291 | end; 292 | 293 | tsSBDATA_IAC: 294 | case c of 295 | TLNT_IAC: 296 | begin 297 | FState := tsIAC_SBDATA; 298 | FSubNeg := FSubNeg + c; 299 | end; 300 | TLNT_SE: 301 | begin 302 | SubReply := ''; 303 | case FSubType of 304 | #24: //termtype 305 | begin 306 | if (FSubNeg <> '') and (FSubNeg[1] = #1) then 307 | SubReply := #0 + FTermType; 308 | end; 309 | end; 310 | Sock.SendString(TLNT_IAC + TLNT_SB + FSubType + SubReply + TLNT_IAC + TLNT_SE); 311 | FState := tsDATA; 312 | end; 313 | else 314 | FState := tsDATA; 315 | end; 316 | 317 | else 318 | FState := tsData; 319 | end; 320 | if Reply <> '' then 321 | Sock.SendString(TLNT_IAC + Reply + c); 322 | end; 323 | 324 | end; 325 | 326 | procedure TTelnetSend.Send(const Value: string); 327 | begin 328 | Sock.SendString(ReplaceString(Value, TLNT_IAC, TLNT_IAC + TLNT_IAC)); 329 | end; 330 | 331 | function TTelnetSend.Login: Boolean; 332 | begin 333 | Result := False; 334 | if not Connect then 335 | Exit; 336 | Result := True; 337 | end; 338 | 339 | function TTelnetSend.SSHLogin: Boolean; 340 | begin 341 | Result := False; 342 | if Connect then 343 | begin 344 | FSock.SSL.SSLType := LT_SSHv2; 345 | FSock.SSL.Username := FUsername; 346 | FSock.SSL.Password := FPassword; 347 | FSock.SSLDoConnect; 348 | Result := FSock.LastError = 0; 349 | end; 350 | end; 351 | 352 | procedure TTelnetSend.Logout; 353 | begin 354 | FSock.CloseSocket; 355 | end; 356 | 357 | 358 | end. 359 | --------------------------------------------------------------------------------