├── .gitignore ├── 3rd └── synopse │ ├── Synopse.inc │ ├── syncommons.pas │ ├── syncrypto.pas │ ├── synfpclinux.pas │ ├── synfpctypinfo.pas │ ├── synlz.pas │ └── synopsecommit.inc ├── AUTHORS.txt ├── LICENSE ├── README.md ├── examples ├── s3 │ ├── 01 │ │ ├── s3.lpi │ │ └── s3.pas │ └── 02 │ │ ├── s3demo.ico │ │ ├── s3demo.lpi │ │ ├── s3demo.lpr │ │ ├── s3demo.res │ │ ├── umain.lfm │ │ └── umain.pas └── ses │ └── 01 │ ├── sesdemo.lpi │ ├── sesdemo.lpr │ ├── sesdemo.lps │ ├── sesdemo.res │ ├── unit1.lfm │ └── unit1.pas ├── packages ├── aws.lpk └── aws.pas ├── src ├── aws.inc ├── aws_base.pas ├── aws_client.pas ├── aws_credentials.pas ├── aws_http.pas ├── aws_net.pas ├── aws_s3.pas └── aws_ses.pas └── test ├── test.ico ├── test.lpi ├── test.lpr ├── test.res ├── test_net.pas └── test_s3.pas /.gitignore: -------------------------------------------------------------------------------- 1 | *.[oa] 2 | *.ppu 3 | *.lps 4 | *.compiled 5 | *.bak* 6 | *.exe 7 | *.dll 8 | *.so 9 | *.bat 10 | *.compiled 11 | *.ini 12 | bin/ 13 | lib/ 14 | packages/lib/ 15 | test/lib/ 16 | examples/s3/01/lib/ 17 | examples/s3/02/lib/ 18 | 19 | 20 | 21 | -------------------------------------------------------------------------------- /3rd/synopse/Synopse.inc: -------------------------------------------------------------------------------- 1 | { 2 | This file is part of Synopse framework. 3 | 4 | Synopse framework. Copyright (C) 2011 Arnaud Bouchez 5 | Synopse Informatique - http://synopse.info 6 | 7 | *** BEGIN LICENSE BLOCK ***** 8 | Version: MPL 1.1/GPL 2.0/LGPL 2.1 9 | 10 | The contents of this file are subject to the Mozilla Public License Version 11 | 1.1 (the "License"); you may not use this file except in compliance with 12 | the License. You may obtain a copy of the License at 13 | http://www.mozilla.org/MPL 14 | 15 | Software distributed under the License is distributed on an "AS IS" basis, 16 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 17 | for the specific language governing rights and limitations under the License. 18 | 19 | The Original Code is Synopse framework. 20 | 21 | The Initial Developer of the Original Code is Arnaud Bouchez. 22 | 23 | Portions created by the Initial Developer are Copyright (C) 2016 24 | the Initial Developer. All Rights Reserved. 25 | 26 | Contributor(s): 27 | Alfred Glaenzer (alf) 28 | 29 | Alternatively, the contents of this file may be used under the terms of 30 | either the GNU General Public License Version 2 or later (the "GPL"), or 31 | the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), 32 | in which case the provisions of the GPL or the LGPL are applicable instead 33 | of those above. If you wish to allow use of your version of this file only 34 | under the terms of either the GPL or the LGPL, and not to allow others to 35 | use your version of this file under the terms of the MPL, indicate your 36 | decision by deleting the provisions above and replace them with the notice 37 | and other provisions required by the GPL or the LGPL. If you do not delete 38 | the provisions above, a recipient may use your version of this file under 39 | the terms of any one of the MPL, the GPL or the LGPL. 40 | 41 | ***** END LICENSE BLOCK ***** 42 | 43 | Version 1.7 44 | - first public release, corresponding to SQLite3 Framework 1.7 45 | 46 | Version 1.8 47 | - force no Range Checking and other compilation settings 48 | 49 | Version 1.10 50 | - code modifications to support Delphi 5 / Delphi 6 compilers 51 | 52 | Version 1.11 53 | - allow to fix Delphi 2009 specific compilation issues :( 54 | 55 | Version 1.13 56 | - updated conditionals for FPC 57 | - code modifications for Delphi 5 compiler 58 | - new WITHLOG conditional (defined by default) 59 | 60 | Version 1.15 61 | - now handles Delphi XE2 (32 Bit) 62 | 63 | Version 1.16 64 | - added USEPACKAGES conditional to help compiling the unit within packages 65 | - added ISDELPHIXE conditional for fixing some compilation warnings 66 | - added DOPATCHTRTL conditional (not set by default, for compatibility) 67 | 68 | Version 1.18 69 | - added SQLITE3_FASTCALL conditional (shared by SQLite3 related units) 70 | - added NEWRTTINOTUSED conditional (unset by default, for compatibility) - see 71 | http://synopse.info/forum/viewtopic.php?id=1394 72 | - enhanced FPC compatibility 73 | - now handles Delphi XE3, XE4, XE5, XE6, XE7 and XE8 (32 and 64 bit) 74 | 75 | } 76 | 77 | {.$define PUREPASCAL} 78 | // define this if your compiler doesn't support Delphi's x86 asm 79 | // - is set automaticaly in case of a 64 bits compiler (only FPC exists now) 80 | 81 | {$define USENORMTOUPPER} 82 | // if defined, text functions will use the NormToUpper[] array, as defined 83 | // in our custom SysUtils.pas (not the LVCL version) -> when using LVCL, 84 | // define the global LVCL compiler directive, and this unit will initialize 85 | // its own NormToUpper[] array 86 | // -> define ENHANCEDRTL conditional below if our Enhanced RTL IS installed 87 | // -> in practice, this conditional is ALWAYS DEFINED, since needed by SQLite3 88 | 89 | {.$define ENHANCEDRTL} 90 | // define this if you DID install our Enhanced Runtime library or the LVCL: 91 | // - it's better to define this conditional globaly in the Project/Options window 92 | // - we need to hack the "legacy" LoadResString() procedure and add a 93 | // LoadResStringTranslate() function, for on the fly resourcestring i18n 94 | // - it will also define the TwoDigitLookup[] array and some very fast x86 asm 95 | // IntToStr() and other functions, available in our Enhanced Runtime library 96 | // (and our LVCL library) 97 | // - it will be unset automaticaly (see below) for Delphi 2009 and up 98 | // - this conditional must be defined in both SQLite3Commons and SQLite3i18n units, 99 | // or (even better) globally in the Project options 100 | 101 | {.$define USEPACKAGES} 102 | // define this if you compile the unit within a Delphi package 103 | // - it will avoid error like "[DCC Error] E2201 Need imported data reference ($G) 104 | // to access 'VarCopyProc' from unit 'SynCommons'" 105 | // - shall be set at the package options level, and left untouched by default 106 | 107 | {$define WITHLOG} 108 | // if defined, logging will be supported via the TSQLLog family 109 | // - should be left defined: TSQLog.Family.Level default setting won't log 110 | // anything, so there won't be any noticeable performance penalty to have 111 | // this WITHLOG conditional defined, which is expected by high-level units 112 | // of the framework, like DDD or UI 113 | 114 | {.$define DOPATCHTRTL} 115 | // if defined, the low-level patches made to RecordCopy() low-level function 116 | // as defined in SynCommons.pas will be applied (if applicable to your Delphi 117 | // version) - you should better use it, but we have unset it by default 118 | 119 | {.$define NEWRTTINOTUSED} 120 | // if defined, the new RTTI (available since Delphi 2010) won't be linked to 121 | // the executable: resulting file size will be much smaller, and mORMot won't 122 | // be affected (unless you use the enhanced RTTI for record/dynamic array JSON 123 | // serialization) - left undefined by default to ensure minimal impact 124 | 125 | {.$define NOSETTHREADNAME} 126 | // if defined, SetThreadName() would not raise the exception used to set the 127 | // thread name: to be defined if you have issues when debugging your application 128 | 129 | {.$define USELOCKERDEBUG} 130 | // by default, some IAutoLocker instances would use TAutoLocker, unless this 131 | // conditional is defined to use more verbose TAutoLockerDebug 132 | // (may be used for race condition debugging, in multi-threaded apps) 133 | 134 | {.$define OLDTEXTWRITERFORMAT} 135 | // force TTextWriter.Add(Format) to handle the alternate $ % tags 136 | 137 | {$ifdef LVCL} 138 | // NormToUpper[] exists only in our enhanced RTL 139 | {$define OWNNORMTOUPPER} 140 | // LVCL does not support variants 141 | {$define NOVARIANTS} 142 | {$endif} 143 | 144 | {$ifdef UNICODE} 145 | {$undef ENHANCEDRTL} // Delphi 2009 and up don't have our Enhanced Runtime library 146 | {$define HASVARUSTRING} 147 | {$define HASCODEPAGE} 148 | { due to a bug in Delphi 2009+, we need to fake inheritance of record, 149 | since TDynArrayHashed = object(TDynArray) fails to initialize 150 | http://blog.synopse.info/post/2011/01/29/record-and-object-issue-in-Delphi-2010 } 151 | {$define UNDIRECTDYNARRAY} 152 | {$endif} 153 | 154 | 155 | {$define INCLUDE_FTS3} 156 | // define this if you want to include the FTS3/FTS4 feature into the library 157 | // - FTS3 is an SQLite module implementing full-text search 158 | // - will include also FTS4 extension module since 3.7.4 159 | // - see http://www.sqlite.org/fts3.html for documentation 160 | // - is defined by default, but can be unset by defining EXCLUDE_FTS3 conditional 161 | // to save about 50 KB of code size (is it worth it nowdays?) 162 | // - should be defined for SynSQLite3, SynSQLite3Static and mORMotSQLite3 units, 163 | // so a global condition in this Synopse.inc does make sense 164 | 165 | {$ifdef EXCLUDE_FTS3} 166 | {$undef INCLUDE_FTS3} 167 | {$endif} 168 | 169 | { Free Pascal adaptation notes: 170 | - we use the Delphi compatibility mode 171 | - from system.pp use these constants (Win32/64 values listed): 172 | LineEnding = #13#10; 173 | DirectorySeparator = '\'; 174 | - for Cross-Platform and all CPU: 175 | integer is NOT CPU-dependent (thanks to objpas), i.e. always 32 bits 176 | cardinal is NOT CPU-dependent (thanks to objpas), i.e. always 32 bits 177 | PtrUInt is an unsigned integer type of same size as a pointer / register 178 | -> must be used for pointer arithmetic 179 | -> may be used in loops 180 | PtrInt is a signed integer type of same size as a pointer / register 181 | -> must be used for pointer arithmetic 182 | -> may be used in loops 183 | all 32 bits x86 asm code can be replaced by a pascal only version, with 184 | if the conditional define PUREPASCAL is set (defined below e.g. for CPUX64) 185 | } 186 | 187 | {$ifdef FPC} 188 | 189 | {$ifndef FPC_DELPHI} 190 | {$MODE DELPHI} // e.g. for asm syntax - disabled for FPC 2.6 compatibility 191 | {$endif} 192 | 193 | {$INLINE ON} 194 | {$MINENUMSIZE 1} 195 | {$PACKSET 1} 196 | {$PACKENUM 1} 197 | {$CODEPAGE UTF8} // otherwise unexpected behavior occurs in most cases 198 | 199 | {$undef ENHANCEDRTL} // there is no version of our Enhanced RTL for FPC 200 | {$undef DOPATCHTRTL} 201 | {$define DELPHI5ORFPC} 202 | {$define USETYPEINFO} // will use SynFPCTypInfo.pas wrapper 203 | {$define HASINLINE} 204 | {$define NODELPHIASM} // ignore low-level System.@LStrFromPCharLen calls 205 | {$define HASAESNI} 206 | {$define HASTTHREADSTART} 207 | {$define HASINTERFACEASTOBJECT} 208 | {$define FPC_OR_UNICODE} 209 | {$define FPC_ENUMHASINNER} 210 | 211 | {.$define FPCSQLITE3STATIC} 212 | // allow static linking of the SQlite3 engine (including crypto) to the project 213 | // -> enabled to support static-linked SQLite3 engine, after retrieval of 214 | // the needed .o files from http://synopse.info/files/sqlite3fpc.7z 215 | // -> could be disabled to force external .so/.dll linking 216 | // -> only available for Win32 and Linux32 platforms by now 217 | 218 | {$ifdef MSWINDOWS} 219 | {$define FPCSQLITE3STATIC} // we supply Win32 and Win64 .obj 220 | {$endif} 221 | {$ifdef LINUX} 222 | {$ifdef CPUX86} 223 | {$define FPCSQLITE3STATIC} // we supply Linux 32-bit x86 .o 224 | {$endif} 225 | {$endif} 226 | 227 | {$ifdef ANDROID} 228 | {$define LINUX} 229 | {$endif} 230 | 231 | {$ifdef DARWIN} 232 | {$define LINUX} // not true, but a POSIX/BSD system 233 | {$define PUREPASCAL} // e.g. low-level stack layout differs 234 | {$endif} 235 | 236 | {$ifdef CPU64} 237 | {$define PUREPASCAL} // e.g. x64, AARCH64 238 | {$ifdef CPUX64} 239 | {$define CPUINTEL} 240 | {$ASMMODE INTEL} // as Delphi expects 241 | {$endif CPUX64} 242 | {$else} 243 | {$ifdef CPUARM} 244 | {$define PUREPASCAL} // ARM32 245 | {$endif CPUARM} 246 | {$ifdef CPUX86} 247 | {$define CPUINTEL} 248 | {$ASMMODE INTEL} // as Delphi expects 249 | {$endif CPUX86} 250 | {$endif CPU64} 251 | 252 | // FPC has its own RTTI layout only since late 3.x 253 | // when http://bugs.freepascal.org/view.php?id=26774 has been fixed 254 | {$ifdef FPC_HAS_EXTENDEDINTERFACERTTI} // use dedicated branch conditional 255 | {$ifdef CPUINTEL} 256 | {$define HASINTERFACERTTI} 257 | {$endif} 258 | {$ifdef CPUARM} 259 | {$define HASINTERFACERTTI} 260 | {$endif} 261 | {$ifdef CPUAARCH64} 262 | {$define HASINTERFACERTTI} 263 | {$endif} 264 | {$endif FPC_HAS_EXTENDEDINTERFACERTTI} 265 | 266 | {$define FPC_OR_PUREPASCAL} 267 | {$define FPC_OR_KYLIX} 268 | // exceptions interception code in FPC differs from Delphi 269 | {$define NOEXCEPTIONINTERCEPT} 270 | 271 | // $if FPC_FULLVERSION>20700 breaks Delphi 6-7 and SynProject :( 272 | {$ifdef VER2_7} 273 | {$define ISFPC27} 274 | {$endif} 275 | {$ifdef VER3_0} 276 | {$define ISFPC27} 277 | {$define HASDIRECTTYPEINFO} 278 | // PTypeInfo would be stored with no pointer de-reference 279 | // => Delphi and newer FPC uses a pointer reference to ease exe linking 280 | {$endif} 281 | {$ifdef VER3_1} 282 | {$define ISFPC27} 283 | {.$define HASDIRECTTYPEINFO} 284 | // define this for trunk revisions older than June 2016 - see 285 | // http://wiki.freepascal.org/User_Changes_Trunk#RTTI_Binary_format_change 286 | {$endif} 287 | {$ifdef FPC_HAS_CPSTRING} 288 | // see http://wiki.freepascal.org/FPC_Unicode_support 289 | {$define HASCODEPAGE} // UNICODE means {$mode delphiunicode} 290 | {$endif} 291 | {$ifdef ISFPC27} 292 | {$define ISFPC271} 293 | {$define HASVARUSTRING} 294 | {$define HASVARUSTRARG} 295 | // defined if the http://mantis.freepascal.org/view.php?id=26773 bug is fixed 296 | // you should use 2.7.1/trunk branch in revision 28995 from 2014-11-05T22:17:54 297 | // => this will change the TInvokeableVariantType.SetProperty() signature 298 | {$define FPC_VARIANTSETVAR} 299 | {$endif} 300 | {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} 301 | {$define FPC_ENUMHASINNER} 302 | {$endif} 303 | 304 | {$else FPC} 305 | 306 | {$ifndef PUREPASCAL} // if PUREPASCAL is forced, ignore any x86/x64 asm 307 | {$define CPUINTEL} // no NextGen support yet 308 | {$endif} 309 | {$ifdef CPUX64} 310 | {$define CPU64} // Delphi compiler for 64 bit CPU 311 | {$define CPU64DELPHI} 312 | {$undef CPU32} 313 | {$define PUREPASCAL} // no x86 32 bit asm to be used 314 | {$else CPUX64} 315 | {$define CPU32} // Delphi compiler for 32 bit CPU 316 | {$undef CPU64} 317 | {$define CPUX86} // for compatibility with older versions of Delphi 318 | {$endif CPUX64} 319 | 320 | // defines if exceptions shall not be intercepted 321 | {.$define NOEXCEPTIONINTERCEPT} 322 | 323 | {$IFDEF CONDITIONALEXPRESSIONS} // Delphi 6 or newer 324 | {$define HASINTERFACERTTI} // interface RTTI (not FPC) 325 | {$ifdef LINUX} 326 | {$if RTLVersion = 14.5} 327 | {$define KYLIX3} 328 | {$define FPC_OR_KYLIX} 329 | // Kylix 3 will be handled just like Delphi 7 330 | {$undef ENHANCEDRTL} // Enhanced Runtime library not fully tested yet 331 | {$define DOPATCHTRTL} // nice speed up for server apps 332 | {$define NOVARCOPYPROC} 333 | {$define NOSQLITE3STATIC} // Kylix will use external sqlite3.so 334 | {$else} 335 | Kylix1/2 are unsupported 336 | {$ifend} 337 | {$else} 338 | {$ifdef VER140} 339 | {$define ISDELPHI6ANDUP} // Delphi 6 or newer 340 | {$define DELPHI6OROLDER} 341 | {$define NOVARCOPYPROC} 342 | {$undef ENHANCEDRTL} // Delphi 6 doesn't have our Enhanced Runtime library 343 | {$else} 344 | {$define ISDELPHI7ANDUP} // Delphi 7 or newer 345 | {$define WITHUXTHEME} // VCL handle UI theming 346 | {$warn UNSAFE_CODE OFF} // Delphi for .Net does not exist any more! 347 | {$warn UNSAFE_TYPE OFF} 348 | {$warn UNSAFE_CAST OFF} 349 | {$warn DUPLICATE_CTOR_DTOR OFF} // avoid W1029 unneeded hints 350 | {$endif} 351 | {$endif LINUX} 352 | {$if CompilerVersion >= 17} 353 | {$ifend} 354 | {$if CompilerVersion >= 18} 355 | {$define ISDELPHI2006ANDUP} // Delphi 2006 or newer 356 | {$define HASNEWFILEAGE} 357 | {$define HASINLINE} 358 | {$define HASREGION} 359 | {$define HASFASTMM4} 360 | {$ifend} 361 | {$if CompilerVersion > 18} 362 | {$define ISDELPHI2007ANDUP} // Delphi 2007 or newer 363 | {$ifend} 364 | {$if CompilerVersion = 20} 365 | {$define ISDELPHI2009} // Delphi 2009 has specific compilation issues :( 366 | // for Delphi 2009 and up, use UNICODE conditional :) 367 | {$define FPC_OR_UNICODE} 368 | {$ifend} 369 | {$if CompilerVersion >= 21.0} 370 | // Delphi 2010/XE: Reduce EXE size by disabling much RTTI 371 | {$define ISDELPHI2010} 372 | {$define FPC_OR_UNICODE} 373 | {$define HASTTHREADSTART} 374 | {$define HASINTERFACEASTOBJECT} 375 | {$ifdef NEWRTTINOTUSED} 376 | {$WEAKLINKRTTI ON} 377 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 378 | {$endif NEWRTTINOTUSED} 379 | {$ifend} 380 | {$if CompilerVersion >= 22.0} 381 | {$define ISDELPHIXE} 382 | {$ifend} 383 | {$if CompilerVersion >= 23.0} 384 | // Delphi XE2 has some cross-platform features 385 | // e.g. {$ifdef ISDELPHIXE2}VCL.Graphics{$else}Graphics{$endif} 386 | {$define ISDELPHIXE2} 387 | {$define HASVARUSTRARG} 388 | {$ifend} 389 | {$if CompilerVersion >= 24.0} 390 | {$define ISDELPHIXE3} 391 | {$ifend} 392 | {$if CompilerVersion >= 25.0} 393 | {$define ISDELPHIXE4} 394 | {$define HASAESNI} 395 | {$ifend} 396 | {$if CompilerVersion >= 26.0} 397 | {$define ISDELPHIXE5} 398 | {$define PUBLISHRECORD} 399 | // if defined, will handle RTTI available only since Delphi XE5 for 400 | // record published properties 401 | {$ifend} 402 | {$if CompilerVersion >= 27.0} 403 | {$define ISDELPHIXE6} 404 | {$ifend} 405 | {$if CompilerVersion >= 28.0} 406 | {$define ISDELPHIXE7} 407 | {$ifend} 408 | {$if CompilerVersion >= 29.0} 409 | {$define ISDELPHIXE8} 410 | {$ifend} 411 | {$if CompilerVersion >= 30.0} 412 | {$define ISDELPHI10} 413 | {$ifend} 414 | {$if CompilerVersion >= 31.0} 415 | {$define ISDELPHI101} 416 | {$ifend} 417 | {$if CompilerVersion >= 32.0} 418 | {$define ISDELPHI102} 419 | {$ifend} 420 | {$ELSE} 421 | // Delphi 5 or older 422 | {$define DELPHI6OROLDER} 423 | {$define DELPHI5OROLDER} 424 | {$define DELPHI5ORFPC} 425 | {$define MSWINDOWS} 426 | {$define NOVARIANTS} 427 | {$define NOVARCOPYPROC} 428 | {$undef ENHANCEDRTL} // Delphi 5 doesn't have our Enhanced Runtime library 429 | {$undef DOPATCHTRTL} 430 | {$ENDIF} 431 | 432 | {$endif FPC} 433 | 434 | {$ifdef PUREPASCAL} 435 | {$define NODELPHIASM} 436 | {$define FPC_OR_PUREPASCAL} 437 | {$undef DOPATCHTRTL} 438 | {$else} 439 | {$endif PUREPASCAL} 440 | 441 | {$R-} // disable Range checking in our code 442 | {$S-} // disable Stack checking in our code 443 | {$X+} // expect extended syntax 444 | {$W-} // disable stack frame generation 445 | {$Q-} // disable overflow checking in our code 446 | {$B-} // expect short circuit boolean 447 | {$V-} // disable Var-String Checking 448 | {$T-} // Typed @ operator 449 | {$Z1} // enumerators stored as byte by default 450 | {$IFNDEF FPC} 451 | {$P+} // Open string params 452 | {$ENDIF FPC} 453 | 454 | {$ifdef VER150} 455 | {$WARN SYMBOL_DEPRECATED OFF} 456 | {$WARN UNSAFE_TYPE OFF} 457 | {$WARN UNSAFE_CODE OFF} 458 | {$WARN UNSAFE_CAST OFF} 459 | {$ENDIF} 460 | 461 | {$ifdef CONDITIONALEXPRESSIONS} // Delphi 6 or newer 462 | {$WARN SYMBOL_PLATFORM OFF} 463 | {$WARN UNIT_PLATFORM OFF} 464 | {$endif} 465 | 466 | // see http://synopse.info/fossil/tktview?name=6593f0fbd1 467 | {$ifndef WITHUXTHEME} 468 | {$define EXTENDEDTOSTRING_USESTR} // no TFormatSettings before Delphi 6 469 | {$endif} 470 | {$ifdef LVCL} 471 | {$define EXTENDEDTOSTRING_USESTR} // no FloatToText implemented in LVCL 472 | {$endif} 473 | {$ifdef FPC} 474 | {$define EXTENDEDTOSTRING_USESTR} // FloatToText uses str() in FPC 475 | {$endif} 476 | {$ifdef CPU64} 477 | {$define EXTENDEDTOSTRING_USESTR} // FloatToText() much slower in x64 mode 478 | {$endif} 479 | 480 | // global conditional to use SQLite3 with fastcall calling convention 481 | // used by SynSQLite3, SynSQLite3Static, SynSQlite3RegEx and mORMotSQLite3 units 482 | {$ifdef CPU64} 483 | // only one calling convention in the Win64 world 484 | {$ifndef FPC} 485 | {$define SQLITE3_FASTCALL} 486 | {$endif} 487 | {$else} 488 | // undefined by default: BCC32 -pr fastcall (=Delphi resgister) is broken 489 | // because of issues with BCC32 itself, or some obfuscated calls in source? 490 | // -> allow to use external SQlite3 libraries in addition to static version 491 | {.$define SQLITE3_FASTCALL} 492 | {$endif} 493 | 494 | {$ifdef FPC} 495 | {$ifndef FPCSQLITE3STATIC} // see above to enable this conditional 496 | {$define NOSQLITE3STATIC} 497 | {$endif} 498 | {$else} 499 | // Only Win32+Linux32 do support static linked library yet with Delphi 500 | {$ifdef CPU64} 501 | {$define NOSQLITE3STATIC} 502 | {$endif} 503 | {$endif} 504 | {$ifdef CPU64} 505 | {$define NOSQLITE3STATIC} 506 | {$endif} 507 | {$ifdef ANDROID} 508 | {$define NOSQLITE3STATIC} 509 | {$endif} 510 | {$ifdef DARWIN} 511 | {$define NOSQLITE3STATIC} 512 | {$endif} 513 | 514 | {$ifdef NOSQLITE3STATIC} 515 | // our proprietary crypto expects a patched SQlite3.c statically linked 516 | {$define NOSQLITE3ENCRYPT} 517 | {$endif} 518 | 519 | {.$define SQLVIRTUALLOGS} 520 | // enable low-level logging of SQlite3 virtual table query planner costs 521 | // -> to be used only for internal debugging 522 | 523 | {$ifdef MSWINDOWS} 524 | /// define this to publish TWinINet / TWinHttp / TWinHttpAPI classes 525 | // and TSQLHttpClientWinINet / TSQLHttpClientWinHTTP classes 526 | {$define USEWININET} 527 | // our current IOCP pattern is Windows-specific: 528 | // with Thread Pool: 3394 requests / second (each request with 4 KB of data) 529 | // without the Pool: 140/s in the IDE (i.e. one core), 2637/s on a dual core 530 | // but less needed under Linux, since thread creation sounds much cheaper 531 | // see http://www.akkadia.org/drepper/nptl-design.pdf 532 | {$define USETHREADPOOL} 533 | {.$define ONLYUSEHTTPSOCKET} // for testing (no benefit vs http.sys) 534 | {.$define USELIBCURL} // for testing under Windows (no benefit vs WinHTTP) 535 | {$else} 536 | // http.sys server is Windows-specific 537 | {$define ONLYUSEHTTPSOCKET} 538 | {$ifndef ANDROID} 539 | // cross-platform libcurl has a great API -> TCurlHttp and TSQLHttpClientCurl 540 | {$define USELIBCURL} 541 | {$endif} 542 | {$endif} 543 | 544 | // define this to avoid sending "X-Powered-By: Synopse mORMot" HTTP header 545 | {.$define NOXPOWEREDNAME} 546 | 547 | -------------------------------------------------------------------------------- /3rd/synopse/synfpclinux.pas: -------------------------------------------------------------------------------- 1 | /// wrapper for Windows functions translated to Linux for FPC 2 | unit SynFPCLinux; 3 | 4 | { 5 | This file is part of Synopse mORMot framework. 6 | Synopse mORMot framework. Copyright (C) 2016 Arnaud Bouchez 7 | Synopse Informatique - http://synopse.info 8 | *** BEGIN LICENSE BLOCK ***** 9 | Version: MPL 1.1/GPL 2.0/LGPL 2.1 10 | The contents of this file are subject to the Mozilla Public License Version 11 | 1.1 (the "License"); you may not use this file except in compliance with 12 | the License. You may obtain a copy of the License at 13 | http://www.mozilla.org/MPL 14 | Software distributed under the License is distributed on an "AS IS" basis, 15 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 16 | for the specific language governing rights and limitations under the License. 17 | The Original Code is Synopse mORMot framework. 18 | The Initial Developer of the Original Code is Alfred Glaenzer. 19 | Portions created by the Initial Developer are Copyright (C) 2016 20 | the Initial Developer. All Rights Reserved. 21 | Contributor(s): 22 | - Arnaud Bouchez 23 | Alternatively, the contents of this file may be used under the terms of 24 | either the GNU General Public License Version 2 or later (the "GPL"), or 25 | the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), 26 | in which case the provisions of the GPL or the LGPL are applicable instead 27 | of those above. if you wish to allow use of your version of this file only 28 | under the terms of either the GPL or the LGPL, and not to allow others to 29 | use your version of this file under the terms of the MPL, indicate your 30 | decision by deleting the provisions above and replace them with the notice 31 | and other provisions required by the GPL or the LGPL. if you do not delete 32 | the provisions above, a recipient may use your version of this file under 33 | the terms of any one of the MPL, the GPL or the LGPL. 34 | ***** END LICENSE BLOCK ***** 35 | Version 1.18 36 | - initial revision 37 | } 38 | 39 | interface 40 | 41 | {$MODE objfpc} 42 | {$inline on} 43 | {$h+} 44 | {$R-} // disable Range checking in our code 45 | {$S-} // disable Stack checking in our code 46 | 47 | {$ifdef ANDROID} 48 | {$define LINUX} 49 | {$endif} 50 | {$ifdef Darwin} 51 | {$define LINUX} 52 | {$endif} 53 | 54 | uses 55 | SysUtils 56 | {$ifdef Linux} 57 | ,UnixType 58 | {$endif}; 59 | 60 | const 61 | { HRESULT codes, delphi-like } 62 | NOERROR = 0; 63 | NO_ERROR = 0; 64 | INVALID_HANDLE_VALUE = THandle(-1); 65 | 66 | LOCALE_USER_DEFAULT = $400; 67 | NORM_IGNORECASE = 1; 68 | 69 | /// compatibility function, wrapping Win32 API mutex initialization 70 | procedure InitializeCriticalSection(var cs : TRTLCriticalSection); inline; 71 | 72 | /// compatibility function, wrapping Win32 API mutex finalization 73 | procedure DeleteCriticalSection(var cs : TRTLCriticalSection); inline; 74 | 75 | {$ifdef Linux} 76 | 77 | {$ifndef DARWIN} 78 | const 79 | CLOCK_MONOTONIC = 1; 80 | CLOCK_MONOTONIC_COARSE = 6; // see http://lwn.net/Articles/347811 81 | 82 | var 83 | // contains CLOCK_MONOTONIC_COARSE since kernel 2.6.32 84 | CLOCK_MONOTONIC_TICKCOUNT: integer = CLOCK_MONOTONIC; 85 | {$endif} 86 | 87 | /// compatibility function, wrapping Win32 API high resolution timer 88 | procedure QueryPerformanceCounter(var Value: Int64); inline; 89 | 90 | /// compatibility function, wrapping Win32 API high resolution timer 91 | function QueryPerformanceFrequency(var Value: Int64): boolean; 92 | 93 | /// compatibility function, wrapping Win32 API file position change 94 | function SetFilePointer(hFile: cInt; lDistanceToMove: TOff; 95 | lpDistanceToMoveHigh: Pointer; dwMoveMethod: cint): TOff; inline; 96 | 97 | /// compatibility function, wrapping Win32 API file size retrieval 98 | function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD; 99 | 100 | /// compatibility function, wrapping Win32 API file truncate at current position 101 | procedure SetEndOfFile(hFile: cInt); inline; 102 | 103 | /// compatibility function, wrapping Win32 API last error code 104 | function GetLastError: longint; inline; 105 | 106 | /// compatibility function, wrapping Win32 API last error code 107 | procedure SetLastError(error: longint); inline; 108 | 109 | /// compatibility function, wrapping Win32 API text comparison 110 | function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: Pwidechar; 111 | cchCount1: longint; lpString2: Pwidechar; cchCount2: longint): longint; inline; 112 | 113 | /// returns the current UTC time 114 | function GetNowUTC: TDateTime; 115 | 116 | /// returns the current UTC time as TSystemTime 117 | procedure GetNowUTCSystem(var result: TSystemTime); 118 | 119 | var 120 | /// will contain the current Linux kernel revision, as one integer 121 | // - e.g. $030d02 for 3.13.2, or $020620 for 2.6.32 122 | KernelRevision: cardinal; 123 | 124 | 125 | /// compatibility function, to be implemented according to the running OS 126 | // - expect more or less the same result as the homonymous Win32 API function 127 | function GetTickCount64: Int64; 128 | 129 | /// compatibility function, to be implemented according to the running OS 130 | // - expect more or less the same result as the homonymous Win32 API function 131 | function GetTickCount: cardinal; 132 | 133 | /// similar to Windows sleep() API call, to be truly cross-platform 134 | // - it should have a millisecond resolution, and handle ms=0 as a switch to 135 | // another pending thread, i.e. call sched_yield() API 136 | procedure SleepHiRes(ms: cardinal); 137 | 138 | {$endif Linux} 139 | 140 | 141 | implementation 142 | 143 | {$ifdef Linux} 144 | uses 145 | Classes, Unix, BaseUnix, {$ifndef Darwin}linux,{$endif} dynlibs; 146 | {$endif} 147 | 148 | procedure InitializeCriticalSection(var cs : TRTLCriticalSection); 149 | begin 150 | InitCriticalSection(cs); 151 | end; 152 | 153 | procedure DeleteCriticalSection(var cs : TRTLCriticalSection); 154 | begin 155 | {$ifdef Linux} 156 | if cs.__m_kind<>0 then 157 | DoneCriticalSection(cs); 158 | {$endif} 159 | end; 160 | 161 | {$ifdef Linux} 162 | 163 | const // Date Translation - see http://en.wikipedia.org/wiki/Julian_day 164 | HoursPerDay = 24; 165 | MinsPerHour = 60; 166 | SecsPerMin = 60; 167 | MinsPerDay = HoursPerDay*MinsPerHour; 168 | SecsPerDay = MinsPerDay*SecsPerMin; 169 | SecsPerHour = MinsPerHour*SecsPerMin; 170 | C1970 = 2440588; 171 | D0 = 1461; 172 | D1 = 146097; 173 | D2 = 1721119; 174 | 175 | procedure JulianToGregorian(JulianDN: integer; out Year,Month,Day: Word); 176 | var YYear,XYear,Temp,TempMonth: integer; 177 | begin 178 | Temp := ((JulianDN-D2) shl 2)-1; 179 | JulianDN := Temp div D1; 180 | XYear := (Temp mod D1) or 3; 181 | YYear := (XYear div D0); 182 | Temp := ((((XYear mod D0)+4) shr 2)*5)-3; 183 | Day := ((Temp mod 153)+5) div 5; 184 | TempMonth := Temp div 153; 185 | if TempMonth>=10 then begin 186 | inc(YYear); 187 | dec(TempMonth,12); 188 | end; 189 | inc(TempMonth,3); 190 | Month := TempMonth; 191 | Year := YYear+(JulianDN*100); 192 | end; 193 | 194 | procedure EpochToLocal(epoch: integer; out year,month,day,hour,minute,second: Word); 195 | begin 196 | JulianToGregorian((Epoch div SecsPerDay)+c1970,year,month,day); 197 | Epoch := abs(Epoch mod SecsPerDay); 198 | Hour := Epoch div SecsPerHour; 199 | Epoch := Epoch mod SecsPerHour; 200 | Minute := Epoch div SecsPerMin; 201 | Second := Epoch mod SecsPerMin; 202 | end; 203 | 204 | function GetNowUTC: TDateTime; 205 | var SystemTime: TSystemTime; 206 | begin 207 | GetNowUTCSystem(SystemTime); 208 | result := SystemTimeToDateTime(SystemTime); 209 | end; 210 | 211 | procedure GetNowUTCSystem(var result: TSystemTime); 212 | var tz: timeval; 213 | begin 214 | fpgettimeofday(@tz,nil); 215 | EpochToLocal(tz.tv_sec,result.year,result.month,result.day,result.hour,result.Minute,result.Second); 216 | result.MilliSecond := tz.tv_usec div 1000; 217 | end; 218 | 219 | function GetTickCount: cardinal; 220 | begin 221 | result := cardinal(GetTickCount64); 222 | end; 223 | 224 | const 225 | C_THOUSAND = Int64(1000); 226 | C_MILLION = Int64(C_THOUSAND * C_THOUSAND); 227 | C_BILLION = Int64(C_THOUSAND * C_THOUSAND * C_THOUSAND); 228 | 229 | {$ifdef DARWIN} 230 | // clock_gettime() is not implemented: http://stackoverflow.com/a/5167506/458259 231 | 232 | type 233 | TTimebaseInfoData = record 234 | Numer: cardinal; 235 | Denom: cardinal; 236 | end; 237 | 238 | function mach_absolute_time: UInt64; 239 | cdecl external 'libc.dylib' name 'mach_absolute_time'; 240 | function mach_timebase_info(var TimebaseInfoData: TTimebaseInfoData): Integer; 241 | cdecl external 'libc.dylib' name 'mach_timebase_info'; 242 | 243 | procedure QueryPerformanceCounter(var Value: Int64); 244 | var info: TTimebaseInfoData; 245 | begin // returns time in nano second resolution 246 | mach_timebase_info(info); 247 | if info.Denom=1 then 248 | if info.Numer=1 then 249 | // seems to be the case on Intel CPUs 250 | Value := mach_absolute_time else 251 | Value := mach_absolute_time*info.Numer else 252 | // use floating point to avoid potential overflow 253 | Value := round(mach_absolute_time*(info.Numer/info.Denom)); 254 | end; 255 | 256 | function QueryPerformanceFrequency(var Value: Int64):boolean; 257 | begin 258 | Value := C_BILLION; // 1 second = 1e9 nanoseconds 259 | result := true; 260 | end; 261 | 262 | function GetTickCount64: Int64; 263 | begin 264 | QueryPerformanceCounter(result); 265 | result := result div C_MILLION; // 1 millisecond = 1e6 nanoseconds 266 | end; 267 | 268 | {$else} 269 | 270 | function GetTickCount64: Int64; 271 | var tp: timespec; 272 | begin 273 | clock_gettime(CLOCK_MONOTONIC_TICKCOUNT,@tp); 274 | Result := (Int64(tp.tv_sec) * 1000) + (tp.tv_nsec div 1000000); 275 | end; 276 | 277 | procedure QueryPerformanceCounter(var Value: Int64); 278 | var r : TTimeSpec; 279 | begin 280 | clock_gettime(CLOCK_MONOTONIC,@r); 281 | value := r.tv_nsec+r.tv_sec*C_BILLION; 282 | end; 283 | 284 | function QueryPerformanceFrequency(var Value: Int64):boolean; 285 | var r : TTimeSpec; 286 | FIsHighResolution : boolean; 287 | begin 288 | FIsHighResolution := (clock_getres(CLOCK_MONOTONIC,@r) = 0); 289 | FIsHighResolution := FIsHighResolution and (r.tv_nsec <> 0); 290 | if (r.tv_nsec <> 0) then 291 | value := C_BILLION div (r.tv_nsec+(r.tv_sec*C_BILLION)); 292 | result := FIsHighResolution; 293 | end; 294 | 295 | {$endif DARWIN} 296 | 297 | function SetFilePointer(hFile: cInt; lDistanceToMove: TOff; 298 | lpDistanceToMoveHigh: Pointer; dwMoveMethod: cint): TOff; 299 | var offs: Int64; 300 | begin 301 | Int64Rec(offs).Lo := lDistanceToMove; 302 | if lpDistanceToMoveHigh=nil then 303 | Int64Rec(offs).Hi := 0 else 304 | Int64Rec(offs).Hi := PDWord(lpDistanceToMoveHigh)^; 305 | offs := FpLseek(hFile,offs,dwMoveMethod); 306 | result := Int64Rec(offs).Lo; 307 | if lpDistanceToMoveHigh<>nil then 308 | PDWord(lpDistanceToMoveHigh)^ := Int64Rec(offs).Hi; 309 | end; 310 | 311 | procedure SetEndOfFile(hFile: cInt); 312 | begin 313 | FpFtruncate(hFile,FPLseek(hFile,0,SEEK_CUR)); 314 | end; 315 | 316 | function GetLastError: longint; 317 | begin 318 | result := fpgeterrno; 319 | end; 320 | 321 | procedure SetLastError(error: longint); 322 | begin 323 | fpseterrno(error); 324 | end; 325 | 326 | function CompareStringW(GetThreadLocale: DWORD; dwCmpFlags: DWORD; lpString1: Pwidechar; 327 | cchCount1: longint; lpString2: Pwidechar; cchCount2: longint): longint; 328 | var W1,W2: WideString; 329 | begin 330 | W1 := lpString1; 331 | W2 := lpString2; 332 | if dwCmpFlags and NORM_IGNORECASE<>0 then 333 | result := WideCompareText(W1,W2) else 334 | result := WideCompareStr(W1,W2); 335 | end; 336 | 337 | function GetFileSize(hFile: cInt; lpFileSizeHigh: PDWORD): DWORD; 338 | var FileInfo: TStat; 339 | begin 340 | if fpFstat(hFile,FileInfo)<>0 then 341 | FileInfo.st_Size := 0; // returns 0 on error 342 | result := Int64Rec(FileInfo.st_Size).Lo; 343 | if lpFileSizeHigh<>nil then 344 | lpFileSizeHigh^ := Int64Rec(FileInfo.st_Size).Hi; 345 | end; 346 | 347 | procedure SleepHiRes(ms: cardinal); 348 | begin 349 | SysUtils.Sleep(ms); 350 | end; 351 | 352 | {$ifndef DARWIN} 353 | 354 | procedure GetKernelRevision; 355 | var uts: UtsName; 356 | P: PAnsiChar; 357 | function GetNext: cardinal; 358 | var c: cardinal; 359 | begin 360 | result := 0; 361 | repeat 362 | c := ord(P^)-48; 363 | if c>9 then 364 | break else 365 | result := result*10+c; 366 | inc(P); 367 | until false; 368 | if P^='.' then 369 | inc(P); 370 | end; 371 | begin 372 | fpuname(uts); 373 | P := @uts.release; 374 | KernelRevision := GetNext shl 16+GetNext shl 8+GetNext; 375 | if KernelRevision>=$020620 then // expects kernel 2.6.32 or higher 376 | CLOCK_MONOTONIC_TICKCOUNT := CLOCK_MONOTONIC_COARSE else 377 | CLOCK_MONOTONIC_TICKCOUNT := CLOCK_MONOTONIC; 378 | end; 379 | 380 | initialization 381 | GetKernelRevision; 382 | {$endif DARWIN} 383 | {$endif Linux} 384 | end. 385 | -------------------------------------------------------------------------------- /3rd/synopse/synfpctypinfo.pas: -------------------------------------------------------------------------------- 1 | /// wrapper around FPC typinfo.pp unit for SynCommons.pas and mORMot.pas 2 | unit SynFPCTypInfo; 3 | 4 | { 5 | This file is part of Synopse mORMot framework. 6 | Synopse mORMot framework. Copyright (C) 2016 Arnaud Bouchez 7 | Synopse Informatique - http://synopse.info 8 | *** BEGIN LICENSE BLOCK ***** 9 | Version: MPL 1.1/GPL 2.0/LGPL 2.1 10 | The contents of this file are subject to the Mozilla Public License Version 11 | 1.1 (the "License"); you may not use this file except in compliance with 12 | the License. You may obtain a copy of the License at 13 | http://www.mozilla.org/MPL 14 | Software distributed under the License is distributed on an "AS IS" basis, 15 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 16 | for the specific language governing rights and limitations under the License. 17 | The Original Code is Synopse mORMot framework. 18 | The Initial Developer of the Original Code is Alfred Glaenzer. 19 | Portions created by the Initial Developer are Copyright (C) 2016 20 | the Initial Developer. All Rights Reserved. 21 | Contributor(s): 22 | - Arnaud Bouchez 23 | Alternatively, the contents of this file may be used under the terms of 24 | either the GNU General Public License Version 2 or later (the "GPL"), or 25 | the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), 26 | in which case the provisions of the GPL or the LGPL are applicable instead 27 | of those above. if you wish to allow use of your version of this file only 28 | under the terms of either the GPL or the LGPL, and not to allow others to 29 | use your version of this file under the terms of the MPL, indicate your 30 | decision by deleting the provisions above and replace them with the notice 31 | and other provisions required by the GPL or the LGPL. if you do not delete 32 | the provisions above, a recipient may use your version of this file under 33 | the terms of any one of the MPL, the GPL or the LGPL. 34 | ***** END LICENSE BLOCK ***** 35 | Version 1.18 36 | - initial revision 37 | } 38 | 39 | interface 40 | 41 | {$MODE objfpc} 42 | {$MODESWITCH AdvancedRecords} 43 | {$inline on} 44 | {$h+} 45 | 46 | uses 47 | SysUtils, 48 | TypInfo; 49 | 50 | const 51 | ptField = 0; 52 | ptStatic = 1; 53 | ptVirtual = 2; 54 | ptConst = 3; 55 | 56 | {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} 57 | function AlignToPtr(p : pointer): pointer; inline; 58 | function GetFPCAlignPtr(P: pointer): pointer; inline; 59 | {$else FPC_REQUIRES_PROPER_ALIGNMENT} 60 | type 61 | AlignToPtr = pointer; 62 | {$endif FPC_REQUIRES_PROPER_ALIGNMENT} 63 | 64 | function GetFPCEnumName(TypeInfo: PTypeInfo; Value: Integer): PShortString; inline; 65 | function GetFPCEnumValue(TypeInfo: PTypeInfo; const Name: string): Integer; inline; 66 | function GetFPCTypeData(TypeInfo: PTypeInfo): PTypeData; inline; 67 | function GetFPCPropInfo(AClass: TClass; const PropName: string): PPropInfo; inline; 68 | 69 | 70 | implementation 71 | 72 | {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} 73 | function AlignToPtr(p : pointer): pointer; inline; 74 | begin 75 | result := align(p,sizeof(p)); 76 | end; 77 | {$endif} 78 | 79 | function GetFPCEnumValue(TypeInfo: PTypeInfo; const Name: string): Integer; 80 | var PS: PShortString; 81 | PT: PTypeData; 82 | Count: longint; 83 | sName: shortstring; 84 | begin 85 | if Length(Name)=0 then 86 | exit(-1); 87 | sName := Name; 88 | PT := GetFPCTypeData(TypeInfo); 89 | Count := 0; 90 | Result := -1; 91 | 92 | if TypeInfo^.Kind=tkBool then begin 93 | if CompareText(BooleanIdents[false],Name)=0 then 94 | result := 0 else 95 | if CompareText(BooleanIdents[true],Name)=0 then 96 | result := 1; 97 | end else 98 | begin 99 | PS := @PT^.NameList; 100 | while (Result=-1) and (PByte(PS)^<>0) do begin 101 | if ShortCompareText(PS^, sName) = 0 then 102 | Result := Count+PT^.MinValue; 103 | PS := PShortString(pointer(PS)+PByte(PS)^+1); 104 | Inc(Count); 105 | end; 106 | end; 107 | end; 108 | 109 | function GetFPCEnumName(TypeInfo: PTypeInfo; Value: Integer): PShortString; 110 | const NULL_SHORTSTRING: string[1] = ''; 111 | Var PS: PShortString; 112 | PT: PTypeData; 113 | begin 114 | PT := GetFPCTypeData(TypeInfo); 115 | if TypeInfo^.Kind=tkBool then begin 116 | case Value of 117 | 0,1: Result := @BooleanIdents[Boolean(Value)]; 118 | else Result := @NULL_SHORTSTRING; 119 | end; 120 | end else begin 121 | PS := @PT^.NameList; 122 | dec(Value,PT^.MinValue); 123 | while Value>0 do begin 124 | PS := PShortString(pointer(PS)+PByte(PS)^+1); 125 | Dec(Value); 126 | end; 127 | Result := PS; 128 | end; 129 | end; 130 | 131 | function GetFPCTypeData(TypeInfo: PTypeInfo): PTypeData; 132 | begin 133 | result := PTypeData(AlignToPtr(PTypeData(pointer(TypeInfo)+2+PByte(pointer(TypeInfo)+1)^))); 134 | end; 135 | 136 | {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} 137 | 138 | function GetFPCAlignPtr(P: pointer): pointer; 139 | begin 140 | result := AlignToPtr(P-SizeOf(Pointer)+2+PByte(P)[1]); 141 | end; 142 | 143 | {$endif} 144 | 145 | { 146 | procedure getMethodList(aClass:TClass); 147 | Type PMethodEntry=^TMethodEntry; 148 | TMethodEntry=packed record 149 | size:Word; 150 | Adr:pointer; 151 | Name:Shortstring; 152 | end; 153 | var mTable:ppointer; 154 | ClassName:String; 155 | MethodCount:PWord; 156 | MethodEntry:PMethodEntry; 157 | i:integer; 158 | begin 159 | while aClass<>nil do 160 | begin 161 | mTable := pointer(integer(aClass)+vmtMethodTable); 162 | if (mTable<>nil)and(mTable^<>nil) then 163 | begin 164 | MethodCount := mTable^; 165 | MethodEntry := pointer(integer(MethodCount)+2); 166 | ClassName := aClass.ClassName; 167 | for i := 1 to MethodCount^ do 168 | begin 169 | writeln(MethodEntry^.Name); 170 | MethodEntry := pointer(integer(MethodEntry)+MethodEntry^.size); 171 | end; 172 | end; 173 | aClass := aClass.ClassParent; 174 | end; 175 | end; 176 | } 177 | 178 | function GetFPCPropInfo(AClass: TClass; const PropName: string): PPropInfo; 179 | begin 180 | result := typinfo.GetPropInfo(AClass,PropName); 181 | end; 182 | 183 | end. 184 | -------------------------------------------------------------------------------- /3rd/synopse/synlz.pas: -------------------------------------------------------------------------------- 1 | /// SynLZ Compression routines 2 | // - licensed under a MPL/GPL/LGPL tri-license; version 1.18 3 | unit SynLZ; 4 | 5 | { 6 | This file is part of Synopse SynLZ Compression. 7 | Synopse SynLZ Compression. Copyright (C) 2016 Arnaud Bouchez 8 | Synopse Informatique - http://synopse.info 9 | *** BEGIN LICENSE BLOCK ***** 10 | Version: MPL 1.1/GPL 2.0/LGPL 2.1 11 | The contents of this file are subject to the Mozilla Public License Version 12 | 1.1 (the "License"); you may not use this file except in compliance with 13 | the License. You may obtain a copy of the License at 14 | http://www.mozilla.org/MPL 15 | Software distributed under the License is distributed on an "AS IS" basis, 16 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 17 | for the specific language governing rights and limitations under the License. 18 | The Original Code is Synopse SynLZ Compression. 19 | The Initial Developer of the Original Code is Arnaud Bouchez. 20 | Portions created by the Initial Developer are Copyright (C) 2016 21 | the Initial Developer. All Rights Reserved. 22 | Contributor(s): 23 | Alternatively, the contents of this file may be used under the terms of 24 | either the GNU General Public License Version 2 or later (the "GPL"), or 25 | the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), 26 | in which case the provisions of the GPL or the LGPL are applicable instead 27 | of those above. If you wish to allow use of your version of this file only 28 | under the terms of either the GPL or the LGPL, and not to allow others to 29 | use your version of this file under the terms of the MPL, indicate your 30 | decision by deleting the provisions above and replace them with the notice 31 | and other provisions required by the GPL or the LGPL. If you do not delete 32 | the provisions above, a recipient may use your version of this file under 33 | the terms of any one of the MPL, the GPL or the LGPL. 34 | ***** END LICENSE BLOCK ***** 35 | SynLZ Compression / Decompression library 36 | ========================================= 37 | by Arnaud Bouchez http://bouchez.info 38 | * SynLZ is a very FAST lossless data compression library 39 | written in optimized pascal code for Delphi 3 up to Delphi 2009 40 | with a tuned asm version available 41 | * symetrical compression and decompression speed (which is 42 | very rare above all other compression algorithms in the wild) 43 | * good compression rate (usualy better than LZO) 44 | * fastest averrage compression speed (ideal for xml/text communication, e.g.) 45 | SynLZ implements a new compression algorithm with the following features: 46 | * hashing+dictionary compression in one pass, with no huffman table 47 | * optimized 32bits control word, embedded in the data stream 48 | * in-memory compression (the dictionary is the input stream itself) 49 | * compression and decompression have the same speed (both use hashing) 50 | * thread safe and lossless algorithm 51 | * supports overlapping compression and in-place decompression 52 | * code size for compression/decompression functions is smaller than LZO's 53 | The contents of this file are subject to the Mozilla Public License 54 | Version 1.1 (the "License"); you may not use this file except in 55 | compliance with the License. You may obtain a copy of the License at 56 | http://www.mozilla.org/MPL 57 | Software distributed under the License is distributed on an "AS IS" 58 | basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the 59 | License for the specific language governing rights and limitations 60 | under the License. 61 | The Initial Developer of the Original Code is Arnaud Bouchez. 62 | This work is Copyright (C)2008 Arnaud Bouchez - http://bouchez.info 63 | Conversion notes: 64 | - this format is NOT stream compatible with any lz* official format 65 | => use it internally in your application, not as exchange format 66 | - very small code size (less than 1KB for both compressor/decompressor) 67 | - the uncompressed data length is stored in the beginning of the stream 68 | and can be retrieved easily for proper out_p memory allocation 69 | - please give correct data to the decompressor (i.e. first CRC in_p data) 70 | => we recommend our very fast Adler32 procedure, or a zip-like container 71 | - a 2nd more tuned algorithm is included, but is somewhat slower in practice 72 | => use SynLZ[de]compres1*() functions in your applications 73 | - tested and benchmarked with a lot of data types/sizes 74 | => use the asm code, which is very tuned: SynLZ[de]compress1asm() 75 | - tested under Delphi 7, Delphi 2007 and Delphi 2009 76 | - a hashing limitation makes SynLZ sometimes unable to pack continuous 77 | blocks of same byte -> SynLZ is perfect for xml/text, but SynLZO 78 | is prefered for database files 79 | - if you include it in your application, please give me some credits: 80 | "use SynLZ compression by http://bouchez.info" 81 | - use at your own risk! 82 | Some benchmark on a Sempron computer: 83 | - compression is 20 times faster than zip, decompression 3 times 84 | - same compression ratio as lzo algo, but faster (up to 2x) on compression 85 | - the R and W intermediate speed are at the compressed stream level, i.e. 86 | the speed which used for disk usage -> you see that SynLZ behaves 87 | very well for real-time data compression, for backup purpose e.g. 88 | (a typical SATA disk drive has a speed of 50-70 MB/s) 89 | KLOG.xml 6034 bytes 90 | lz1 asm 1287 21.3% R 256 MB/s W 54 MB/s R 71 MB/s W 334 MB/s 91 | lz1 pas 1287 21.3% R 184 MB/s W 39 MB/s R 58 MB/s W 274 MB/s 92 | lz2 pas 1274 21.1% R 173 MB/s W 36 MB/s R 57 MB/s W 274 MB/s 93 | lzo C 1347 22.3% R 185 MB/s W 41 MB/s R 111 MB/s W 501 MB/s 94 | zip 806 13.4% R 14 MB/s W 1 MB/s R 14 MB/s W 110 MB/s 95 | MiniLZO.cs 25252 bytes 96 | lz1 asm 5775 22.9% R 246 MB/s W 56 MB/s R 70 MB/s W 306 MB/s 97 | lz1 pas 5775 22.9% R 178 MB/s W 40 MB/s R 58 MB/s W 253 MB/s 98 | lz2 pas 5762 22.8% R 166 MB/s W 37 MB/s R 57 MB/s W 250 MB/s 99 | lzo C 5846 23.2% R 164 MB/s W 38 MB/s R 103 MB/s W 448 MB/s 100 | zip 3707 14.7% R 15 MB/s W 2 MB/s R 22 MB/s W 154 MB/s 101 | TestLZO.exe 158720 bytes 102 | lz1 asm 110686 69.7% R 127 MB/s W 88 MB/s R 80 MB/s W 115 MB/s 103 | lz1 pas 110686 69.7% R 98 MB/s W 68 MB/s R 63 MB/s W 90 MB/s 104 | lz2 pas 109004 68.7% R 88 MB/s W 60 MB/s R 60 MB/s W 88 MB/s 105 | lzo C 108202 68.2% R 40 MB/s W 27 MB/s R 164 MB/s W 241 MB/s 106 | zip 88786 55.9% R 5 MB/s W 3 MB/s R 33 MB/s W 60 MB/s 107 | Browsing.sq3db 46047232 bytes (46MB) 108 | lz1 asm 19766884 42.9% R 171 MB/s W 73 MB/s R 73 MB/s W 171 MB/s 109 | lz1 pas 19766884 42.9% R 130 MB/s W 56 MB/s R 59 MB/s W 139 MB/s 110 | lz2 pas 19707346 42.8% R 123 MB/s W 52 MB/s R 59 MB/s W 139 MB/s 111 | lzo asm 20629084 44.8% R 89 MB/s W 40 MB/s R 135 MB/s W 302 MB/s 112 | lzo C 20629083 44.8% R 66 MB/s W 29 MB/s R 145 MB/s W 325 MB/s 113 | zip 15564126 33.8% R 6 MB/s W 2 MB/s R 30 MB/s W 91 MB/s 114 | TRKCHG.DBF 4572297 bytes (4MB) 115 | lz1 asm 265782 5.8% R 430 MB/s W 25 MB/s R 29 MB/s W 510 MB/s 116 | lz1 pas 265782 5.8% R 296 MB/s W 17 MB/s R 28 MB/s W 483 MB/s 117 | lz2 pas 274773 6.0% R 258 MB/s W 15 MB/s R 27 MB/s W 450 MB/s 118 | lzo C 266897 5.8% R 318 MB/s W 18 MB/s R 41 MB/s W 702 MB/s 119 | zip 158408 3.5% R 25 MB/s W 0 MB/s R 11 MB/s W 318 MB/s 120 | CATENA5.TXT 6358752 bytes 121 | lz1 asm 3275269 51.5% R 132 MB/s W 68 MB/s R 66 MB/s W 129 MB/s 122 | lz1 pas 3275269 51.5% R 103 MB/s W 53 MB/s R 57 MB/s W 112 MB/s 123 | lz2 pas 3277397 51.5% R 95 MB/s W 49 MB/s R 57 MB/s W 112 MB/s 124 | lzo C 3289373 51.7% R 63 MB/s W 33 MB/s R 90 MB/s W 175 MB/s 125 | zip 2029096 31.9% R 4 MB/s W 1 MB/s R 29 MB/s W 91 MB/s 126 | Benchmark update - introducing LZ4 at http://code.google.com/p/lz4 127 | 190 MB file containing pascal sources, on a Core 2 duo PC: 128 | LZ4 compression = 1.25 sec, comp. size = 71 MB, decompression = 0.44 sec 129 | SynLZ compression = 1.09 sec, comp. size = 63 MB, decompression = 0.99 sec 130 | zip (1) compression = 6.44 sec, comp. size = 52 MB, decompression = 1.49 sec 131 | zip (6) compression = 20.1 sec, comp. size = 42 MB, decompression = 1.35 sec 132 | Note: zip decompression here uses fast asm optimized version of SynZip.pas 133 | Decompression is slower in SynLZ, due to the algorithm used: it does recreate 134 | the hash table even at decompression, while it is not needed by LZ4. 135 | Having the hash table at hand allows more patterns to be available, so 136 | compression ratio is better, at the expand of a slower speed. 137 | Conclusion: 138 | SynLZ compresses better than LZ4, 139 | SynLZ is faster to compress than LZ4, 140 | but SynLZ is slower to decompress than LZ4, 141 | and SynLZ is still very competitive for our Client-Server mORMot purpose ;) 142 | Revision history 143 | Version 1.6 144 | - first release, associated with the main Synopse SQLite3 framework 145 | Version 1.13 146 | - code modifications to compile with Delphi 5 compiler 147 | - comment refactoring (mostly for inclusion in SynProject documentation) 148 | - new CompressSynLZ function, for THttpSocket.RegisterCompress - this 149 | function will return 'synlzo' as "ACCEPT-ENCODING:" HTTP header parameter 150 | Version 1.15 151 | - force ignore asm version of the code if PUREPASCAL conditional is defined 152 | Version 1.16 153 | - fixed potential GPF issue in Hash32() function 154 | Version 1.17 155 | - Use RawByteString type for CompressSynLZ() function prototype 156 | Version 1.18 157 | - unit fixed and tested with Delphi XE2 and up 64-bit compiler 158 | - introducing SynLZCompress1/SynLZDecompress1 low-level functions 159 | - added SynLZdecompress1partial() function for partial and secure (but slower) 160 | decompression - implements feature request [82ca067959] 161 | - removed several compilation hints when assertions are set to off 162 | - some performance optimization, especially when using a 64bit CPU 163 | } 164 | 165 | interface 166 | 167 | {$I Synopse.inc} 168 | 169 | /// get maximum possible (worse) compressed size for out_p 170 | function SynLZcompressdestlen(in_len: integer): integer; 171 | 172 | /// get uncompressed size from lz-compressed buffer (to reserve memory, e.g.) 173 | function SynLZdecompressdestlen(in_p: PAnsiChar): integer; 174 | 175 | /// 1st compression algorithm uses hashing with a 32bits control word 176 | function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 177 | 178 | /// 1st compression algorithm uses hashing with a 32bits control word 179 | // - this is the fastest pure pascal implementation 180 | function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 181 | 182 | /// 1st compression algorithm uses hashing with a 32bits control word 183 | // - this overload function is slower, but will allow to uncompress only the start 184 | // of the content (e.g. to read some metadata header) 185 | // - it will also check for dst buffer overflow, so will be more secure than 186 | // other functions, which expect the content to be verified (e.g. via CRC) 187 | function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar; 188 | maxDst: integer): integer; 189 | 190 | {$ifdef PUREPASCAL} 191 | var 192 | /// fastest available SynLZ compression (using 1st algorithm) 193 | SynLZCompress1: function( 194 | src: PAnsiChar; size: integer; dst: PAnsiChar): integer = SynLZcompress1pas; 195 | 196 | /// fastest available SynLZ decompression (using 1st algorithm) 197 | SynLZDecompress1: function( 198 | src: PAnsiChar; size: integer; dst: PAnsiChar): integer = SynLZDecompress1pas; 199 | 200 | {$else} 201 | 202 | /// optimized x86 asm version of the 1st compression algorithm 203 | function SynLZcompress1asm(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 204 | /// optimized x86 asm version of the 1st compression algorithm 205 | function SynLZdecompress1asm(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 206 | 207 | /// fastest available SynLZ compression (using x86 asm on 1st algorithm) 208 | function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 209 | 210 | /// fastest available SynLZ decompression (using x86 asm on 1st algorithm) 211 | function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 212 | {$endif PUREPASCAL} 213 | 214 | /// 2nd compression algorithm optimizing pattern copy 215 | // - this algorithm is a bit smaller, but slower, so the 1st method is preferred 216 | function SynLZcompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 217 | /// 2nd compression algorithm optimizing pattern copy 218 | // - this algorithm is a bit smaller, but slower, so the 1st method is preferred 219 | function SynLZdecompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 220 | 221 | implementation 222 | 223 | function SynLZcompressdestlen(in_len: integer): integer; 224 | // get maximum possible (worse) compressed size for out_p 225 | begin 226 | result := in_len+in_len shr 3+16; // worse case 227 | end; 228 | 229 | {$ifndef FPC} 230 | type 231 | PtrUInt = {$ifdef CPUX64} NativeUInt {$else} cardinal {$endif}; 232 | {$endif} 233 | 234 | {$ifdef DELPHI5OROLDER} 235 | type // Delphi 5 doesn't have those base types defined :( 236 | PByte = ^Byte; 237 | PWord = ^Word; 238 | PInteger = ^integer; 239 | PCardinal = ^Cardinal; 240 | IntegerArray = array[0..$effffff] of integer; 241 | PIntegerArray = ^IntegerArray; 242 | 243 | {$endif} 244 | 245 | function SynLZdecompressdestlen(in_p: PAnsiChar): integer; 246 | // get uncompressed size from lz-compressed buffer (to reserve memory, e.g.) 247 | begin 248 | result := PWord(in_p)^; 249 | inc(in_p,2); 250 | if result and $8000<>0 then 251 | result := (result and $7fff) or (integer(PWord(in_p)^) shl 15); 252 | end; 253 | 254 | {$ifndef PUREPASCAL} 255 | // using direct x86 jmp also circumvents Internal Error C11715 for Delphi 5 256 | function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 257 | asm 258 | jmp SynLzCompress1Asm 259 | end; 260 | 261 | function SynLZcompress1asm(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 262 | asm 263 | push ebp 264 | push ebx 265 | push esi 266 | push edi 267 | push eax 268 | mov eax, 8 269 | @@0906: add esp, -4092 270 | push eax 271 | dec eax 272 | jnz @@0906 273 | mov eax, [esp+8000H] 274 | add esp, -32 275 | mov esi, ecx 276 | mov [esp], edx 277 | mov edi, eax 278 | mov [esp+8H], esi 279 | mov eax,[esp] 280 | cmp eax, 32768 281 | jl @@0889 282 | and eax, 7FFFH 283 | or eax, 8000H 284 | mov [esi], ax 285 | mov eax, [esp] 286 | shr eax, 15 287 | mov [esi+2], ax 288 | add esi, 4 289 | jmp @@0891 290 | @@0890: mov eax, 2 291 | jmp @@0904 292 | @@0889: mov [esi], ax 293 | test eax,eax 294 | jz @@0890 295 | add esi,2 296 | @@0891: mov eax, [esp] 297 | add eax, edi 298 | mov [esp+0CH], eax 299 | mov eax, [esp+0CH] 300 | sub eax, 11 301 | mov [esp+10H], eax 302 | xor ebx, ebx 303 | mov eax, esi 304 | mov [esp+18H], eax 305 | xor edx, edx 306 | mov [eax], edx 307 | add esi, 4 308 | lea eax, [esp+24H] 309 | xor ecx, ecx 310 | mov edx, 16384 311 | call system.@fillchar 312 | // main loop: 313 | cmp edi, [esp+10H] 314 | ja @@0900 315 | @@0892: mov edx, [edi] 316 | mov eax, edx 317 | shr edx, 12 318 | xor edx, eax 319 | and edx, 0FFFH 320 | mov ebp, [esp+edx*4+24H] 321 | mov ecx, [esp+edx*4+4024H] 322 | mov [esp+edx*4+24H], edi 323 | xor ecx, eax 324 | mov [esp+1CH], ecx 325 | test ecx, 0FFFFFFH 326 | mov [esp+edx*4+4024H], eax 327 | jnz @@0897 328 | mov eax, edi 329 | or ebp,ebp 330 | jz @@0897 331 | sub eax, ebp 332 | cmp eax, 2 333 | mov ecx, [esp+18H] 334 | jle @@0897 335 | mov eax,[ecx] 336 | lea edi,[edi+2] 337 | bts eax,ebx 338 | add ebp, 2 339 | mov [ecx],eax 340 | mov ecx, [esp+0CH] 341 | mov eax, 1 342 | sub ecx, edi 343 | dec ecx 344 | mov [esp+20H], ecx 345 | cmp ecx, 271 346 | jl @@0894 347 | mov dword ptr [esp+20H], 271 348 | jmp @@0894 349 | @@0893: inc eax 350 | @@0894: mov cl, [ebp+eax] 351 | cmp cl, [edi+eax] 352 | jnz @@0895 353 | cmp eax, [esp+20H] 354 | jge @@0895 355 | @@1893: inc eax 356 | @@1894: mov cl, [ebp+eax] 357 | cmp cl, [edi+eax] 358 | jnz @@0895 359 | cmp eax, [esp+20H] 360 | jge @@0895 361 | @@2893: inc eax 362 | @@2894: mov cl, [ebp+eax] 363 | cmp cl, [edi+eax] 364 | jnz @@0895 365 | cmp eax, [esp+20H] 366 | jl @@0893 367 | @@0895: add edi, eax 368 | shl edx, 4 369 | cmp eax, 15 370 | jg @@0896 371 | or eax, edx 372 | mov word ptr [esi], ax 373 | add esi, 2 374 | jmp @@0898 375 | @@0896: sub eax, 16 376 | mov [esi], dx 377 | mov [esi+2H], al 378 | add esi, 3 379 | jmp @@0898 380 | @@0897: mov al, [edi] 381 | mov [esi], al 382 | inc edi 383 | inc esi 384 | @@0898: cmp bl, 31 385 | jnc @@0899 386 | cmp edi, [esp+10H] 387 | lea ebx,[ebx+1] 388 | jbe @@0892 389 | jmp @@0900 390 | @@0899: mov [esp+18H], esi 391 | xor edx, edx 392 | mov [esi], edx 393 | add esi, 4 394 | xor ebx, ebx 395 | cmp edi, [esp+10H] 396 | jbe @@0892 397 | @@0900: cmp edi, [esp+0CH] 398 | jnc @@0903 399 | @@0901: mov al, [edi] 400 | mov [esi], al 401 | inc edi 402 | inc esi 403 | cmp bl, 31 404 | jnc @@0902 405 | cmp edi, [esp+0CH] 406 | lea ebx,[ebx+1] 407 | jc @@0901 408 | jmp @@0903 409 | @@0902: xor ebx, ebx 410 | mov [esi], ebx 411 | lea esi,[esi+4] 412 | cmp edi, [esp+0CH] 413 | jc @@0901 414 | @@0903: mov eax, esi 415 | sub eax, [esp+8H] 416 | @@0904: add esp, 32804 417 | pop edi 418 | pop esi 419 | pop ebx 420 | pop ebp 421 | end; 422 | {$endif PUREPASCAL} 423 | 424 | type 425 | TByteArray = array[0..3] of byte; 426 | PByteArray = ^TByteArray; 427 | 428 | function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 429 | var dst_beg, // initial dst value 430 | src_end, // real last byte available in src 431 | src_endmatch, // last byte to try for hashing 432 | o: PAnsiChar; 433 | CWbit: byte; 434 | CWpoint: PCardinal; 435 | v, h, cached, t, tmax: PtrUInt; 436 | offset: array[0..4095] of PAnsiChar; 437 | cache: array[0..4095] of cardinal; // 16KB+16KB=32KB on stack (48KB under Win64) 438 | begin 439 | dst_beg := dst; 440 | // 1. store in_len 441 | if size>=$8000 then begin // size in 32KB..2GB -> stored as integer 442 | PWord(dst)^ := $8000 or (size and $7fff); 443 | PWord(dst+2)^ := size shr 15; 444 | inc(dst,4); 445 | end else begin 446 | PWord(dst)^ := size ; // size<32768 -> stored as word 447 | if size=0 then begin 448 | result := 2; 449 | exit; 450 | end; 451 | inc(dst,2); 452 | end; 453 | // 2. compress 454 | src_end := src+size; 455 | src_endmatch := src_end-(6+5); 456 | CWbit := 0; 457 | CWpoint := pointer(dst); 458 | PCardinal(dst)^ := 0; 459 | inc(dst,sizeof(CWpoint^)); 460 | fillchar(offset,sizeof(offset),0); // fast 16KB reset to 0 461 | // 1. main loop to search using hash[] 462 | if src<=src_endmatch then 463 | repeat 464 | v := PCardinal(src)^; 465 | h := ((v shr 12) xor v) and 4095; 466 | o := offset[h]; 467 | offset[h] := src; 468 | cached := v xor cache[h]; // o=nil if cache[h] is uninitialized 469 | cache[h] := v; 470 | if (cached and $00ffffff=0) and (o<>nil) and (src-o>2) then begin 471 | CWpoint^ := CWpoint^ or (1 shl CWbit); 472 | inc(src,2); 473 | inc(o,2); 474 | t := 1; 475 | tmax := src_end-src-1; 476 | if tmax>=(255+16) then 477 | tmax := (255+16); 478 | while (o[t]=src[t]) and (t0 483 | if t<=15 then begin // mark 2 to 17 bytes -> size=1..15 484 | PWord(dst)^ := integer(t or h); 485 | inc(dst,2); 486 | end else begin // mark 18 to (255+16) bytes -> size=0, next byte=t 487 | dec(t,16); 488 | PWord(dst)^ := h; // size=0 489 | dst[2] := ansichar(t); 490 | inc(dst,3); 491 | end; 492 | end else begin 493 | dst^ := src^; 494 | inc(src); 495 | inc(dst); 496 | end; 497 | if CWbit<31 then begin 498 | inc(CWbit); 499 | if src<=src_endmatch then continue else break; 500 | end else begin 501 | CWpoint := pointer(dst); 502 | PCardinal(dst)^ := 0; 503 | inc(dst,sizeof(CWpoint^)); 504 | CWbit := 0; 505 | if src<=src_endmatch then continue else break; 506 | end; 507 | until false; 508 | // 2. store remaining bytes 509 | if src0 then begin 557 | result := (result and $7fff) or (integer(PWord(src)^) shl 15); 558 | inc(src,2); 559 | end; 560 | // 2. decompress 561 | last_hashed := dst-1; 562 | CWbit := 32; 563 | nextCW: 564 | CW := PCardinal(src)^; 565 | inc(src,4); 566 | CWbit := CWbit-32; 567 | if src=src_end then break; 578 | while last_hashed=src_end then break; 588 | if last_hashed=src_end then break; 618 | last_hashed := dst-1; 619 | inc(CWbit); 620 | CW := CW shr 1; 621 | if CWbit<32 then 622 | continue else 623 | goto nextCW; 624 | end; 625 | until false; 626 | // assert(result=dst-dst_beg); 627 | end; 628 | 629 | {$ifndef PUREPASCAL} 630 | // using direct x86 jmp also circumvents Internal Error C11715 for Delphi 5 631 | function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 632 | asm 633 | jmp SynLZDecompress1asm 634 | end; 635 | 636 | function SynLZdecompress1asm(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 637 | asm 638 | push ebp 639 | push ebx 640 | push esi 641 | push edi 642 | push eax 643 | mov eax, 4 644 | @@0906: add esp, -4092 645 | push eax 646 | dec eax 647 | jnz @@0906 648 | mov eax, [esp+4000H] 649 | add esp, -24 650 | mov esi, ecx 651 | mov ebx, eax 652 | mov [esp+8H], esi 653 | add edx, ebx 654 | mov [esp+10H], edx 655 | movzx eax, word ptr [ebx] 656 | mov [esp], eax 657 | or eax,eax 658 | je @@0917 659 | add ebx, 2 660 | mov eax, [esp] 661 | test ah, 80H 662 | jz @@0907 663 | and eax, 7FFFH 664 | movzx edx, word ptr [ebx] 665 | shl edx, 15 666 | or eax, edx 667 | mov [esp], eax 668 | add ebx, 2 669 | @@0907: lea ebp, [esi-1] 670 | @@0908: mov ecx, [ebx] 671 | add ebx, 4 672 | mov [esp+14H], ecx 673 | cmp ebx, [esp+10H] 674 | mov edi, 1 675 | jnc @@0917 676 | @@0909: mov ecx, [esp+14H] 677 | @@090A: test ecx, edi 678 | jnz @@0911 679 | mov al, byte ptr [ebx] 680 | inc ebx 681 | mov byte ptr [esi], al 682 | inc esi 683 | cmp ebx, [esp+10H] 684 | lea eax, [esi-3] 685 | jnc @@0917 686 | cmp eax, ebp 687 | jbe @@0910 688 | inc ebp 689 | mov eax, [ebp] 690 | mov edx, eax 691 | shr eax, 12 692 | xor eax, edx 693 | and eax, 0FFFH 694 | mov [esp+eax*4+1CH], ebp 695 | @@0910: add edi, edi 696 | jnz @@090A 697 | jmp @@0908 698 | 699 | @@0911: movzx edx, word ptr [ebx] 700 | add ebx, 2 701 | mov eax, edx 702 | and edx, 0FH 703 | add edx, 2 704 | shr eax, 4 705 | cmp edx,2 706 | jnz @@0912 707 | movzx edx, byte ptr [ebx] 708 | inc ebx 709 | add edx, 18 710 | @@0912: mov eax, [esp+eax*4+1CH] 711 | mov ecx, esi 712 | mov [esp+18H], edx 713 | sub ecx, eax 714 | cmp ecx, edx 715 | jl @@0913 716 | mov ecx, edx 717 | mov edx, esi 718 | call move 719 | @@0914: cmp esi, ebp 720 | jbe @@0916 721 | @@0915: inc ebp 722 | mov edx, [ebp] 723 | mov eax, edx 724 | shr edx, 12 725 | xor eax, edx 726 | and eax, 0FFFH 727 | cmp esi, ebp 728 | mov [esp+eax*4+1CH], ebp 729 | ja @@0915 730 | @@0916: add esi, [esp+18H] 731 | cmp ebx, [esp+10H] 732 | jnc @@0917 733 | add edi, edi 734 | lea ebp, [esi-1] 735 | jz @@0908 736 | jmp @@0909 737 | @@0913: push ebx 738 | xor ecx, ecx 739 | @s: dec edx 740 | mov bl, [eax+ecx] 741 | mov [esi+ecx], bl 742 | lea ecx,[ecx+1] 743 | jnz @s 744 | pop ebx 745 | jmp @@0914 746 | @@0917: mov eax, [esp] 747 | add esp, 16412 748 | pop edi 749 | pop esi 750 | pop ebx 751 | pop ebp 752 | end; 753 | {$endif PUREPASCAL} 754 | 755 | function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 756 | var last_hashed: PAnsiChar; // initial src and dst value 757 | src_end: PAnsiChar; 758 | {$ifdef CPU64} 759 | o: PAnsiChar; 760 | i: PtrUInt; 761 | {$endif} 762 | CW, CWbit: integer; 763 | v, t, h: PtrUInt; 764 | offset: array[0..4095] of PAnsiChar; // 16KB hashing code 765 | label nextCW; 766 | begin 767 | src_end := src+size; 768 | // 1. retrieve out_len 769 | result := PWord(src)^; 770 | if result=0 then exit; 771 | inc(src,2); 772 | if result and $8000<>0 then begin 773 | result := (result and $7fff) or (integer(PWord(src)^) shl 15); 774 | inc(src,2); 775 | end; 776 | // 2. decompress 777 | last_hashed := dst-1; 778 | nextCW: 779 | CW := PCardinal(src)^; 780 | inc(src,4); 781 | CWbit := 1; 782 | if src=src_end then break; 789 | if last_hashed0 then 796 | continue else 797 | goto nextCW; 798 | end else begin 799 | h := PWord(src)^; 800 | inc(src,2); 801 | t := (h and 15)+2; 802 | h := h shr 4; 803 | if t=2 then begin 804 | t := ord(src^)+(16+2); 805 | inc(src); 806 | end; 807 | {$ifdef CPU64} 808 | o := offset[h]; 809 | if (t<8) or (PtrUInt(dst-o)=src_end then break; 819 | while last_hashed0 then 828 | continue else 829 | goto nextCW; 830 | end; 831 | until false; 832 | end; 833 | 834 | function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar; maxDst: integer): integer; 835 | var last_hashed: PAnsiChar; // initial src and dst value 836 | src_end,dst_End: PAnsiChar; 837 | CWbit: integer; 838 | CW, v, t, h: integer; 839 | offset: array[0..4095] of PAnsiChar; // 16KB hashing code 840 | label nextCW; 841 | begin 842 | src_end := src+size; 843 | // 1. retrieve out_len 844 | result := PWord(src)^; 845 | if result=0 then exit; 846 | inc(src,2); 847 | if result and $8000<>0 then begin 848 | result := (result and $7fff) or (integer(PWord(src)^) shl 15); 849 | inc(src,2); 850 | end; 851 | if maxDst=src_end) or (dst>=dst_end) then break; 869 | if last_hashed0 then 876 | continue else 877 | goto nextCW; 878 | end else begin 879 | h := PWord(src)^; 880 | inc(src,2); 881 | t := (h and 15)+2; 882 | h := h shr 4; 883 | if t=2 then begin 884 | t := ord(src^)+(16+2); 885 | inc(src); 886 | end; 887 | if dst+t>=dst_end then begin 888 | movechars(offset[h],dst,dst_end-dst); 889 | break; 890 | end; 891 | if dst-offset[h]=src_end then break; 895 | while last_hashed0 then 904 | continue else 905 | goto nextCW; 906 | end; 907 | until false; 908 | end; 909 | 910 | 911 | function SynLZcompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 912 | var dst_beg, // initial dst value 913 | src_end, // real last byte available in src 914 | src_endmatch, // last byte to try for hashing 915 | o: PAnsiChar; 916 | CWbit: byte; 917 | CWpoint: PCardinal; 918 | h, v, cached: integer; 919 | t, tmax, tdiff, i: integer; 920 | offset: array[0..4095] of PAnsiChar; // 16KB+16KB=32KB hashing code 921 | cache: array[0..4095] of integer; 922 | label dotdiff; 923 | begin 924 | dst_beg := dst; 925 | // 1. store in_len 926 | if size>=$8000 then begin 927 | PWord(dst)^ := $8000 or (size and $7fff); 928 | PWord(dst+2)^ := size shr 15; 929 | inc(dst,4); 930 | end else begin 931 | PWord(dst)^ := size ; // src<32768 -> stored as word, otherwise as integer 932 | if size=0 then begin 933 | result := 2; 934 | exit; 935 | end; 936 | inc(dst,2); 937 | end; 938 | // 2. compress 939 | src_end := src+size; 940 | src_endmatch := src_end-(6+5); 941 | CWbit := 0; 942 | CWpoint := pointer(dst); 943 | PCardinal(dst)^ := 0; 944 | inc(dst,sizeof(CWpoint^)); 945 | tdiff := 0; 946 | fillchar(offset,sizeof(offset),0); // fast 16KB reset to 0 947 | // 1. main loop to search using hash[] 948 | if src<=src_endmatch then 949 | repeat 950 | v := PCardinal(src)^; 951 | h := ((v shr 12) xor v) and 4095; 952 | o := offset[h]; 953 | offset[h] := src; 954 | cached := v xor cache[h]; 955 | cache[h] := v; 956 | if (cached and $00ffffff=0) and (o<>nil) and (src-o>2) then begin 957 | // SetBit(CWpoint,CWbit); 958 | // asm movzx eax,byte ptr CWbit; bts [CWpoint],eax; end 959 | if tdiff<>0 then begin 960 | dec(src,tdiff); 961 | dotdiff:v := tdiff; 962 | if v<=8 then begin 963 | if CWBit+v>31 then begin 964 | for i := CWBit to 31 do begin 965 | dst^ := src^; 966 | inc(dst); 967 | inc(src); 968 | end; 969 | CWpoint := pointer(dst); 970 | PCardinal(dst)^ := 0; 971 | inc(dst,4); 972 | CWBit := (CWBit+v) and 31; 973 | for i := 1 to CWBit do begin 974 | dst^ := src^; 975 | inc(dst); 976 | inc(src); 977 | end; 978 | end else begin 979 | inc(CWBit,v); 980 | for i := 1 to v do begin 981 | dst^ := src^; 982 | inc(dst); 983 | inc(src); 984 | end; 985 | end; 986 | end else begin 987 | CWpoint^ := CWpoint^ or (1 shl CWbit); 988 | dec(v,9); 989 | if v>15 then begin 990 | v := 15; // v=9..24 -> h=0..15 991 | dst^ := #$ff; // size=15 -> tdiff 992 | end else 993 | dst^ := ansichar((v shl 4) or 15); // size=15 -> tdiff 994 | inc(dst); 995 | pInt64(dst)^ := pInt64(src)^; 996 | inc(dst,8); 997 | inc(src,8); 998 | for i := 1 to v+1 do begin 999 | dst^ := src^; 1000 | inc(dst); 1001 | inc(src); 1002 | end; 1003 | if CWBit<31 then 1004 | inc(CWBit) else begin 1005 | CWpoint := pointer(dst); 1006 | PCardinal(dst)^ := 0; 1007 | inc(dst,4); 1008 | CWbit := 0; 1009 | end; 1010 | dec(tdiff,24); 1011 | if tdiff>0 then 1012 | goto dotdiff; 1013 | end; 1014 | end; 1015 | // assert(PWord(o)^=PWord(src)^); 1016 | tdiff := 0; 1017 | CWpoint^ := CWpoint^ or (1 shl CWbit); 1018 | inc(src,2); 1019 | inc(o,2); 1020 | t := 0; // t=matchlen-2 1021 | tmax := src_end-src; 1022 | if tmax>=(255+15) then 1023 | tmax := (255+15); 1024 | while (o[t]=src[t]) and (t0); 1029 | // here we have always t>0 1030 | if t<15 then begin // store t=1..14 -> size=t=1..14 1031 | PWord(dst)^ := integer(t or h); 1032 | inc(dst,2); 1033 | end else begin // store t=15..255+15 -> size=0, next byte=matchlen-15-2 1034 | dst[2] := ansichar(t-15); 1035 | PWord(dst)^ := h; // size=0 1036 | inc(dst,3); 1037 | end; 1038 | if CWbit<31 then begin 1039 | inc(CWbit); 1040 | if src<=src_endmatch then continue else break; 1041 | end else begin 1042 | CWpoint := pointer(dst); 1043 | PCardinal(dst)^ := 0; 1044 | inc(dst,4); 1045 | CWbit := 0; 1046 | if src<=src_endmatch then continue else break; 1047 | end; 1048 | end else begin 1049 | inc(src); 1050 | inc(tdiff); 1051 | if src<=src_endmatch then continue else break; 1052 | end; 1053 | until false; 1054 | // 2. store remaining bytes 1055 | dec(src,tdiff); // force store trailing bytes 1056 | if src0 then begin 1094 | result := (result and $7fff) or (integer(PWord(src)^) shl 15); 1095 | inc(src,2); 1096 | end; 1097 | // 2. decompress 1098 | last_hashed := dst-1; 1099 | nextCW: 1100 | CW := PCardinal(src)^; 1101 | inc(src,4); 1102 | CWbit := 1; 1103 | if src=src_end then break; 1110 | if last_hashed0 then 1117 | continue else 1118 | goto nextCW; 1119 | end else begin 1120 | case ord(src^) and 15 of // get size 1121 | 0: begin // size=0 -> next byte=matchlen-15-2 1122 | h := PWord(src)^ shr 4; 1123 | t := ord(src[2])+(15+2); 1124 | inc(src,3); 1125 | if dst-offset[h] tdiff 1131 | inc(src); 1132 | dst^ := src^; 1133 | inc(dst); 1134 | end; 1135 | inc(src); 1136 | if src>=src_end then break; 1137 | while last_hashed0 then 1144 | continue else 1145 | goto nextCW; 1146 | end; 1147 | else begin // size=1..14=matchlen-2 1148 | h := PWord(src)^; 1149 | inc(src,2); 1150 | t := (h and 15)+2; 1151 | h := h shr 4; 1152 | if dst-offset[h]=src_end then break; 1164 | last_hashed := dst-1; 1165 | CWbit := CWbit shl 1; 1166 | if CWbit<>0 then 1167 | continue else 1168 | goto nextCW; 1169 | end; 1170 | until false; 1171 | {$ifopt C+} 1172 | assert(result=dst-dst_beg); 1173 | {$endif} 1174 | end; 1175 | 1176 | function Hash32(P: PIntegerArray; L: integer): cardinal; 1177 | // faster than Adler32, even asm version, because read DWORD aligned data 1178 | var s1,s2: cardinal; 1179 | i: integer; 1180 | begin 1181 | if P<>nil then begin 1182 | s1 := 0; 1183 | s2 := 0; 1184 | for i := 1 to L shr 4 do begin // 16 bytes (4 DWORD) by loop - aligned read 1185 | inc(s1,P^[0]); 1186 | inc(s2,s1); 1187 | inc(s1,P^[1]); 1188 | inc(s2,s1); 1189 | inc(s1,P^[2]); 1190 | inc(s2,s1); 1191 | inc(s1,P^[3]); 1192 | inc(s2,s1); 1193 | inc(PByte(P),16); 1194 | end; 1195 | for i := 1 to (L shr 2)and 3 do begin // 4 bytes (DWORD) by loop 1196 | inc(s1,P^[0]); 1197 | inc(s2,s1); 1198 | inc(PInteger(P)); 1199 | end; 1200 | case L and 3 of // remaining 0..3 bytes 1201 | 1: inc(s1,PByte(P)^); 1202 | 2: inc(s1,PWord(P)^); 1203 | 3: inc(s1,PWord(P)^ or (PByteArray(P)^[2] shl 16)); 1204 | end; 1205 | inc(s2,s1); 1206 | result := s1 xor (s2 shl 16); 1207 | end else 1208 | result := 0; 1209 | end; 1210 | 1211 | 1212 | end. 1213 | -------------------------------------------------------------------------------- /3rd/synopse/synopsecommit.inc: -------------------------------------------------------------------------------- 1 | '1.18.2778' 2 | -------------------------------------------------------------------------------- /AUTHORS.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbs99/aws/c39a3d7e3f5cf72951c601ddf961ea215a8c4fcf/AUTHORS.txt -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Marcos Douglas B. Santos 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 | **AWS Lib** is minimalist implementation, truly **object-oriented** and **interface-based** with **immutable** objects, 2 | for Amazon Web Services. 3 | 4 | The code have some principles: 5 | 1. all classes are sealed 6 | 2. all methods return an interface or primitive type 7 | 3. all public methods are implementations of interface methods 8 | 4. all instances are immutable 9 | 5. memory is released automatically 10 | 11 | ## A "Bigger" Example using **Amazon S3** 12 | 13 | Bellow you see a complete example to create a new Bucket and send a file on it. 14 | 15 | ``` pascal 16 | program s3; 17 | {$mode objfpc}{$H+} 18 | uses 19 | aws_client, 20 | aws_s3; 21 | 22 | begin 23 | TS3Service.New( 24 | TAWSClient.New( 25 | TAWSSignatureVersion1.New( 26 | TAWSCredentials.New('access_key', 'secret_key', True) 27 | ) 28 | ) 29 | ) 30 | .Buckets 31 | .Put('mys3examplebucket', '/') 32 | .Objects 33 | .Put('foo.txt', 'plain', './foo.txt', ''); 34 | end. 35 | ``` 36 | 37 | First a Region object was created -- this is your connection to the Amazon services. 38 | 39 | Second, using just one line, the code creates a new Bucket and put a new file on it. 40 | 41 | No need to release memory! 42 | 43 | To get this file that was sent, use the code: 44 | 45 | ``` pascal 46 | TS3Service.New( 47 | TAWSClient.New( 48 | TAWSSignatureVersion1.New( 49 | TAWSCredentials.New('access_key', 'secret_key', True) 50 | ) 51 | ) 52 | ) 53 | .Buckets 54 | .Get('mys3examplebucket', '/') 55 | .Objects 56 | .Get('foo.txt', '/'); 57 | .Stream 58 | .SaveToFile('./foo.txt'); 59 | ``` 60 | 61 | To delete this file on server, use the code: 62 | 63 | ``` pascal 64 | TS3Service.New( 65 | TAWSClient.New( 66 | TAWSSignatureVersion1.New( 67 | TAWSCredentials.New('access_key', 'secret_key', True) 68 | ) 69 | ) 70 | ) 71 | .Buckets 72 | .Get('mys3examplebucket', '/') 73 | .Objects 74 | .Delete('foo.txt'); 75 | ``` 76 | 77 | ## Dependencies 78 | 79 | There is only one dependency: [Synapse](http://synapse.ararat.cz/doku.php/download) 80 | 81 | Synapse is used as HTTP client. You can customize or create a new client using another lib like lNet, fpHttpClient, whatever. 82 | 83 | ## Got questions? 84 | 85 | If you have questions or general suggestions, don't hesitate to submit 86 | a new [Github issue](https://github.com/mdbs99/AWS/issues/new). 87 | 88 | ## Amazon S3 Documentation 89 | * [REST API](http://docs.aws.amazon.com/AmazonS3/latest/API/APIRest.html) 90 | * [Error responses](http://docs.aws.amazon.com/AmazonS3/latest/API/ErrorResponses.html) 91 | 92 | ## License 93 | 94 | Copyright (c) 2017 Marcos Douglas B. Santos 95 | 96 | Permission is hereby granted, free of charge, to any person obtaining a copy 97 | of this software and associated documentation files (the "Software"), to deal 98 | in the Software without restriction, including without limitation the rights 99 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 100 | copies of the Software, and to permit persons to whom the Software is 101 | furnished to do so, subject to the following conditions: 102 | 103 | The above copyright notice and this permission notice shall be included in all 104 | copies or substantial portions of the Software. 105 | 106 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 107 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 108 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 109 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 110 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 111 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 112 | SOFTWARE. 113 | -------------------------------------------------------------------------------- /examples/s3/01/s3.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | <UseAppBundle Value="False"/> 15 | <ResourceType Value="res"/> 16 | </General> 17 | <i18n> 18 | <EnableI18N LFM="False"/> 19 | </i18n> 20 | <VersionInfo> 21 | <StringTable ProductVersion=""/> 22 | </VersionInfo> 23 | <BuildModes Count="1"> 24 | <Item1 Name="Default" Default="True"/> 25 | </BuildModes> 26 | <PublishOptions> 27 | <Version Value="2"/> 28 | </PublishOptions> 29 | <RunParams> 30 | <local> 31 | <FormatVersion Value="1"/> 32 | </local> 33 | </RunParams> 34 | <RequiredPackages Count="1"> 35 | <Item1> 36 | <PackageName Value="AWS"/> 37 | </Item1> 38 | </RequiredPackages> 39 | <Units Count="1"> 40 | <Unit0> 41 | <Filename Value="s3.pas"/> 42 | <IsPartOfProject Value="True"/> 43 | </Unit0> 44 | </Units> 45 | </ProjectOptions> 46 | <CompilerOptions> 47 | <Version Value="11"/> 48 | <PathDelim Value="\"/> 49 | <Target> 50 | <Filename Value="..\..\..\bin\s3"/> 51 | </Target> 52 | <SearchPaths> 53 | <IncludeFiles Value="$(ProjOutDir)"/> 54 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 55 | </SearchPaths> 56 | <Linking> 57 | <Debugging> 58 | <UseHeaptrc Value="True"/> 59 | </Debugging> 60 | </Linking> 61 | </CompilerOptions> 62 | <Debugging> 63 | <Exceptions Count="3"> 64 | <Item1> 65 | <Name Value="EAbort"/> 66 | </Item1> 67 | <Item2> 68 | <Name Value="ECodetoolError"/> 69 | </Item2> 70 | <Item3> 71 | <Name Value="EFOpenError"/> 72 | </Item3> 73 | </Exceptions> 74 | </Debugging> 75 | </CONFIG> 76 | -------------------------------------------------------------------------------- /examples/s3/01/s3.pas: -------------------------------------------------------------------------------- 1 | program s3; 2 | {$mode objfpc}{$H+} 3 | uses 4 | aws_credentials, 5 | aws_client, 6 | aws_s3; 7 | 8 | begin 9 | TS3Service.New( 10 | TAWSClient.New( 11 | TAWSSignatureVersion1.New( 12 | TAWSCredentials.New('access_key', 'secret_key', True) 13 | ) 14 | ) 15 | ) 16 | .Buckets 17 | .Put('mys3examplebucket', '/') 18 | .Objects 19 | .Put('foo.txt', 'plain', 'foo.txt', ''); 20 | end. 21 | 22 | -------------------------------------------------------------------------------- /examples/s3/02/s3demo.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbs99/aws/c39a3d7e3f5cf72951c601ddf961ea215a8c4fcf/examples/s3/02/s3demo.ico -------------------------------------------------------------------------------- /examples/s3/02/s3demo.lpi: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectOptions> 4 | <Version Value="9"/> 5 | <PathDelim Value="\"/> 6 | <General> 7 | <SessionStorage Value="InProjectDir"/> 8 | <MainUnit Value="0"/> 9 | <Title Value="AWS S3 Demo"/> 10 | <ResourceType Value="res"/> 11 | <UseXPManifest Value="True"/> 12 | <Icon Value="0"/> 13 | </General> 14 | <i18n> 15 | <EnableI18N LFM="False"/> 16 | </i18n> 17 | <VersionInfo> 18 | <StringTable ProductVersion=""/> 19 | </VersionInfo> 20 | <BuildModes Count="1"> 21 | <Item1 Name="Default" Default="True"/> 22 | </BuildModes> 23 | <PublishOptions> 24 | <Version Value="2"/> 25 | </PublishOptions> 26 | <RunParams> 27 | <local> 28 | <FormatVersion Value="1"/> 29 | </local> 30 | </RunParams> 31 | <RequiredPackages Count="2"> 32 | <Item1> 33 | <PackageName Value="AWS"/> 34 | </Item1> 35 | <Item2> 36 | <PackageName Value="LCL"/> 37 | </Item2> 38 | </RequiredPackages> 39 | <Units Count="2"> 40 | <Unit0> 41 | <Filename Value="s3demo.lpr"/> 42 | <IsPartOfProject Value="True"/> 43 | </Unit0> 44 | <Unit1> 45 | <Filename Value="umain.pas"/> 46 | <IsPartOfProject Value="True"/> 47 | <ComponentName Value="frmMain"/> 48 | <HasResources Value="True"/> 49 | <ResourceBaseClass Value="Form"/> 50 | </Unit1> 51 | </Units> 52 | </ProjectOptions> 53 | <CompilerOptions> 54 | <Version Value="11"/> 55 | <PathDelim Value="\"/> 56 | <Target> 57 | <Filename Value="..\..\..\bin\s3demo"/> 58 | </Target> 59 | <SearchPaths> 60 | <IncludeFiles Value="$(ProjOutDir)"/> 61 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 62 | </SearchPaths> 63 | <Linking> 64 | <Debugging> 65 | <DebugInfoType Value="dsDwarf2"/> 66 | <UseHeaptrc Value="True"/> 67 | </Debugging> 68 | <Options> 69 | <Win32> 70 | <GraphicApplication Value="True"/> 71 | </Win32> 72 | </Options> 73 | </Linking> 74 | </CompilerOptions> 75 | <Debugging> 76 | <Exceptions Count="3"> 77 | <Item1> 78 | <Name Value="EAbort"/> 79 | </Item1> 80 | <Item2> 81 | <Name Value="ECodetoolError"/> 82 | </Item2> 83 | <Item3> 84 | <Name Value="EFOpenError"/> 85 | </Item3> 86 | </Exceptions> 87 | </Debugging> 88 | </CONFIG> 89 | -------------------------------------------------------------------------------- /examples/s3/02/s3demo.lpr: -------------------------------------------------------------------------------- 1 | program s3demo; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX}{$IFDEF UseCThreads} 7 | cthreads, 8 | {$ENDIF}{$ENDIF} 9 | Interfaces, // this includes the LCL widgetset 10 | Forms, umain 11 | { you can add units after this }; 12 | 13 | {$R *.res} 14 | 15 | begin 16 | Application.Title := 'AWS S3 Demo'; 17 | RequireDerivedFormResource := True; 18 | Application.Initialize; 19 | Application.CreateForm(TfrmMain, frmMain); 20 | Application.Run; 21 | end. 22 | 23 | -------------------------------------------------------------------------------- /examples/s3/02/s3demo.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbs99/aws/c39a3d7e3f5cf72951c601ddf961ea215a8c4fcf/examples/s3/02/s3demo.res -------------------------------------------------------------------------------- /examples/s3/02/umain.lfm: -------------------------------------------------------------------------------- 1 | object frmMain: TfrmMain 2 | Left = 323 3 | Height = 323 4 | Top = 144 5 | Width = 461 6 | BorderStyle = bsDialog 7 | Caption = 'AWS S3 Demo' 8 | ClientHeight = 323 9 | ClientWidth = 461 10 | Position = poScreenCenter 11 | LCLVersion = '1.5' 12 | object edtAcessKeyId: TEdit 13 | Left = 8 14 | Height = 23 15 | Top = 26 16 | Width = 216 17 | TabOrder = 0 18 | end 19 | object Label1: TLabel 20 | Left = 8 21 | Height = 15 22 | Top = 8 23 | Width = 71 24 | Caption = 'Access Key Id' 25 | ParentColor = False 26 | end 27 | object Label2: TLabel 28 | Left = 232 29 | Height = 15 30 | Top = 8 31 | Width = 54 32 | Caption = 'Secret Key' 33 | ParentColor = False 34 | end 35 | object btnTestAccess: TBitBtn 36 | Left = 128 37 | Height = 30 38 | Top = 56 39 | Width = 200 40 | Caption = 'Test access' 41 | OnClick = btnTestAccessClick 42 | TabOrder = 2 43 | end 44 | object pnlServices: TPanel 45 | Left = 9 46 | Height = 216 47 | Top = 96 48 | Width = 441 49 | BevelInner = bvLowered 50 | ClientHeight = 216 51 | ClientWidth = 441 52 | TabOrder = 3 53 | Visible = False 54 | object Label3: TLabel 55 | Left = 22 56 | Height = 15 57 | Top = 16 58 | Width = 36 59 | Caption = 'Bucket' 60 | ParentColor = False 61 | end 62 | object edtBucketName: TEdit 63 | Left = 22 64 | Height = 23 65 | Top = 35 66 | Width = 152 67 | CharCase = ecLowerCase 68 | TabOrder = 0 69 | end 70 | object btnBucketCheck: TButton 71 | Left = 22 72 | Height = 25 73 | Top = 64 74 | Width = 75 75 | Caption = 'Check' 76 | OnClick = btnBucketCheckClick 77 | TabOrder = 2 78 | end 79 | object btnBucketCreate: TButton 80 | Left = 280 81 | Height = 25 82 | Top = 64 83 | Width = 75 84 | Caption = 'Create' 85 | OnClick = btnBucketCreateClick 86 | TabOrder = 3 87 | end 88 | object btnBucketDelete: TButton 89 | Left = 357 90 | Height = 25 91 | Top = 64 92 | Width = 77 93 | Caption = 'Delete' 94 | OnClick = btnBucketDeleteClick 95 | TabOrder = 4 96 | end 97 | object fneFile: TFileNameEdit 98 | Left = 96 99 | Height = 23 100 | Top = 176 101 | Width = 179 102 | FilterIndex = 0 103 | HideDirectories = False 104 | ButtonWidth = 23 105 | NumGlyphs = 1 106 | MaxLength = 0 107 | TabOrder = 7 108 | OnChange = fneFileChange 109 | end 110 | object btnFileUpload: TButton 111 | Left = 281 112 | Height = 25 113 | Top = 174 114 | Width = 75 115 | Caption = 'Upload' 116 | OnClick = btnFileUploadClick 117 | TabOrder = 9 118 | end 119 | object edtContentType: TEdit 120 | Left = 22 121 | Height = 23 122 | Top = 176 123 | Width = 73 124 | TabOrder = 8 125 | Text = 'text/plan' 126 | end 127 | object btnObjectDelete: TButton 128 | Left = 359 129 | Height = 25 130 | Top = 130 131 | Width = 75 132 | Caption = 'Delete' 133 | OnClick = btnObjectDeleteClick 134 | TabOrder = 6 135 | end 136 | object edtBucketSubResource: TEdit 137 | Left = 176 138 | Height = 23 139 | Top = 35 140 | Width = 256 141 | CharCase = ecLowerCase 142 | TabOrder = 1 143 | end 144 | object Label5: TLabel 145 | Left = 176 146 | Height = 15 147 | Top = 16 148 | Width = 71 149 | Caption = 'Sub Resource' 150 | ParentColor = False 151 | end 152 | object edtObjectName: TEdit 153 | Left = 22 154 | Height = 23 155 | Top = 131 156 | Width = 152 157 | CharCase = ecLowerCase 158 | TabOrder = 5 159 | end 160 | object Label6: TLabel 161 | Left = 22 162 | Height = 15 163 | Top = 112 164 | Width = 35 165 | Caption = 'Object' 166 | ParentColor = False 167 | end 168 | object Bevel1: TBevel 169 | Left = 18 170 | Height = 10 171 | Top = 96 172 | Width = 416 173 | Shape = bsBottomLine 174 | end 175 | object Label7: TLabel 176 | Left = 22 177 | Height = 15 178 | Top = 160 179 | Width = 18 180 | Caption = 'File' 181 | ParentColor = False 182 | end 183 | object edtObjectSubResource: TEdit 184 | Left = 177 185 | Height = 23 186 | Top = 131 187 | Width = 103 188 | CharCase = ecLowerCase 189 | TabOrder = 10 190 | end 191 | object Label9: TLabel 192 | Left = 176 193 | Height = 15 194 | Top = 112 195 | Width = 71 196 | Caption = 'Sub Resource' 197 | ParentColor = False 198 | end 199 | object btnBucketGet: TButton 200 | Left = 99 201 | Height = 25 202 | Top = 64 203 | Width = 75 204 | Caption = 'Get' 205 | OnClick = btnBucketGetClick 206 | TabOrder = 11 207 | end 208 | object btnObjectCreate: TButton 209 | Left = 281 210 | Height = 25 211 | Top = 130 212 | Width = 75 213 | Caption = 'Create' 214 | OnClick = btnObjectCreateClick 215 | TabOrder = 12 216 | end 217 | object btnFileDownload: TButton 218 | Left = 359 219 | Height = 25 220 | Top = 174 221 | Width = 75 222 | Caption = 'Download' 223 | OnClick = btnFileDownloadClick 224 | TabOrder = 13 225 | end 226 | end 227 | object edtSecretKey: TEdit 228 | Left = 232 229 | Height = 23 230 | Top = 26 231 | Width = 218 232 | TabOrder = 1 233 | end 234 | end 235 | -------------------------------------------------------------------------------- /examples/s3/02/umain.pas: -------------------------------------------------------------------------------- 1 | unit umain; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, FileUtil, LazFileUtils, Forms, Controls, Graphics, Dialogs, 9 | StdCtrls, Buttons, ExtCtrls, EditBtn, 10 | //aws 11 | aws_credentials, 12 | aws_client, 13 | aws_s3; 14 | 15 | type 16 | TfrmMain = class(TForm) 17 | edtAcessKeyId: TEdit; 18 | Label1: TLabel; 19 | Label2: TLabel; 20 | btnTestAccess: TBitBtn; 21 | pnlServices: TPanel; 22 | Label3: TLabel; 23 | edtBucketName: TEdit; 24 | btnBucketCheck: TButton; 25 | btnBucketCreate: TButton; 26 | edtSecretKey: TEdit; 27 | btnBucketDelete: TButton; 28 | fneFile: TFileNameEdit; 29 | btnFileUpload: TButton; 30 | edtContentType: TEdit; 31 | btnObjectDelete: TButton; 32 | edtBucketSubResource: TEdit; 33 | Label5: TLabel; 34 | edtObjectName: TEdit; 35 | Label6: TLabel; 36 | Bevel1: TBevel; 37 | Label7: TLabel; 38 | edtObjectSubResource: TEdit; 39 | Label9: TLabel; 40 | btnBucketGet: TButton; 41 | btnObjectCreate: TButton; 42 | btnFileDownload: TButton; 43 | procedure btnTestAccessClick(Sender: TObject); 44 | procedure btnBucketCheckClick(Sender: TObject); 45 | procedure btnBucketCreateClick(Sender: TObject); 46 | procedure btnBucketDeleteClick(Sender: TObject); 47 | procedure btnFileUploadClick(Sender: TObject); 48 | procedure btnObjectDeleteClick(Sender: TObject); 49 | procedure fneFileChange(Sender: TObject); 50 | procedure btnBucketGetClick(Sender: TObject); 51 | procedure btnObjectCreateClick(Sender: TObject); 52 | procedure btnFileDownloadClick(Sender: TObject); 53 | private 54 | FRegion: IS3Service; 55 | end; 56 | 57 | var 58 | frmMain: TfrmMain; 59 | 60 | implementation 61 | 62 | {$R *.lfm} 63 | 64 | { TfrmMain } 65 | 66 | procedure TfrmMain.btnTestAccessClick(Sender: TObject); 67 | begin 68 | FRegion := TS3Service.Create( 69 | TAWSClient.Create( 70 | TAWSSignatureVersion1.New( 71 | TAWSCredentials.New( 72 | edtAcessKeyId.Text, 73 | edtSecretKey.Text, True 74 | ) 75 | ) 76 | ) 77 | ); 78 | if FRegion.Online then 79 | begin 80 | pnlServices.Visible := True; 81 | end 82 | else 83 | begin 84 | pnlServices.Visible := False; 85 | ShowMessage('Access denied.'); 86 | end; 87 | end; 88 | 89 | procedure TfrmMain.btnBucketCheckClick(Sender: TObject); 90 | begin 91 | if FRegion.Buckets.Check(edtBucketName.Text) then 92 | ShowMessage('The bucket exists and you have access!') 93 | else 94 | ShowMessage('Access denied.'); 95 | end; 96 | 97 | procedure TfrmMain.btnBucketCreateClick(Sender: TObject); 98 | begin 99 | FRegion.Buckets.Put(edtBucketName.Text, edtBucketSubResource.Text); 100 | ShowMessage('Success!') 101 | end; 102 | 103 | procedure TfrmMain.btnBucketDeleteClick(Sender: TObject); 104 | begin 105 | FRegion.Buckets.Delete(edtBucketName.Text, edtBucketSubResource.Text); 106 | ShowMessage('Success!') 107 | end; 108 | 109 | procedure TfrmMain.btnFileUploadClick(Sender: TObject); 110 | var 111 | Bkt: IS3Bucket; 112 | begin 113 | if edtBucketName.Text = '' then 114 | begin 115 | ShowMessage('Define a Bucket.'); 116 | edtBucketName.SetFocus; 117 | Exit; 118 | end; 119 | 120 | if not LazFileUtils.FileExistsUTF8(fneFile.FileName) then 121 | begin 122 | ShowMessage('File not exists'); 123 | fneFile.SetFocus; 124 | Exit; 125 | end; 126 | 127 | Bkt := FRegion.Buckets.Get(edtBucketName.Text, edtBucketSubResource.Text); 128 | Bkt.Objects.Put(edtObjectName.Text, edtContentType.Text, fneFile.FileName, edtObjectSubResource.Text); 129 | ShowMessage('Success!') 130 | end; 131 | 132 | procedure TfrmMain.btnFileDownloadClick(Sender: TObject); 133 | var 134 | Bkt: IS3Bucket; 135 | begin 136 | if edtBucketName.Text = '' then 137 | begin 138 | ShowMessage('Define a Bucket.'); 139 | edtBucketName.SetFocus; 140 | Exit; 141 | end; 142 | 143 | Bkt := FRegion.Buckets.Get(edtBucketName.Text, edtBucketSubResource.Text); 144 | Bkt.Objects.Get( 145 | edtObjectName.Text, 146 | edtObjectSubResource.Text 147 | ).Stream.SaveToFile(fneFile.FileName); 148 | ShowMessage('Success!') 149 | end; 150 | 151 | procedure TfrmMain.btnObjectCreateClick(Sender: TObject); 152 | var 153 | Bkt: IS3Bucket; 154 | begin 155 | if edtBucketName.Text = '' then 156 | begin 157 | ShowMessage('Define a Bucket.'); 158 | edtBucketName.SetFocus; 159 | Exit; 160 | end; 161 | 162 | Bkt := FRegion.Buckets.Get(edtBucketName.Text, edtBucketSubResource.Text); 163 | Bkt.Objects.Put(edtObjectName.Text, edtObjectSubResource.Text); 164 | ShowMessage('Success!') 165 | end; 166 | 167 | procedure TfrmMain.btnObjectDeleteClick(Sender: TObject); 168 | var 169 | Bkt: IS3Bucket; 170 | begin 171 | if edtBucketName.Text = '' then 172 | begin 173 | ShowMessage('Define a Bucket.'); 174 | edtBucketName.SetFocus; 175 | Exit; 176 | end; 177 | 178 | Bkt := FRegion.Buckets.Get(edtBucketName.Text, edtBucketSubResource.Text); 179 | Bkt.Objects.Delete(edtObjectName.Text); 180 | ShowMessage('Success!'); 181 | end; 182 | 183 | procedure TfrmMain.fneFileChange(Sender: TObject); 184 | begin 185 | edtObjectName.Text:= ExtractFileName(fneFile.FileName); 186 | end; 187 | 188 | procedure TfrmMain.btnBucketGetClick(Sender: TObject); 189 | begin 190 | FRegion.Buckets.Get(edtBucketName.Text, edtBucketSubResource.Text); 191 | ShowMessage('The bucket exists and you have access!') 192 | end; 193 | 194 | end. 195 | 196 | -------------------------------------------------------------------------------- /examples/ses/01/sesdemo.lpi: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectOptions> 4 | <Version Value="9"/> 5 | <General> 6 | <SessionStorage Value="InProjectDir"/> 7 | <MainUnit Value="0"/> 8 | <Title Value="sesdemo"/> 9 | <ResourceType Value="res"/> 10 | <UseXPManifest Value="True"/> 11 | <Icon Value="0"/> 12 | </General> 13 | <i18n> 14 | <EnableI18N LFM="False"/> 15 | </i18n> 16 | <VersionInfo> 17 | <StringTable ProductVersion=""/> 18 | </VersionInfo> 19 | <BuildModes Count="1"> 20 | <Item1 Name="Default" Default="True"/> 21 | </BuildModes> 22 | <PublishOptions> 23 | <Version Value="2"/> 24 | </PublishOptions> 25 | <RunParams> 26 | <local> 27 | <FormatVersion Value="1"/> 28 | </local> 29 | </RunParams> 30 | <RequiredPackages Count="2"> 31 | <Item1> 32 | <PackageName Value="AWS"/> 33 | </Item1> 34 | <Item2> 35 | <PackageName Value="LCL"/> 36 | </Item2> 37 | </RequiredPackages> 38 | <Units Count="3"> 39 | <Unit0> 40 | <Filename Value="sesdemo.lpr"/> 41 | <IsPartOfProject Value="True"/> 42 | </Unit0> 43 | <Unit1> 44 | <Filename Value="unit1.lfm"/> 45 | <IsPartOfProject Value="True"/> 46 | </Unit1> 47 | <Unit2> 48 | <Filename Value="unit1.pas"/> 49 | <IsPartOfProject Value="True"/> 50 | <ComponentName Value="Form1"/> 51 | <HasResources Value="True"/> 52 | <ResourceBaseClass Value="Form"/> 53 | <UnitName Value="Unit1"/> 54 | </Unit2> 55 | </Units> 56 | </ProjectOptions> 57 | <CompilerOptions> 58 | <Version Value="11"/> 59 | <Target> 60 | <Filename Value="sesdemo"/> 61 | </Target> 62 | <SearchPaths> 63 | <IncludeFiles Value="$(ProjOutDir)"/> 64 | <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> 65 | </SearchPaths> 66 | <Linking> 67 | <Options> 68 | <Win32> 69 | <GraphicApplication Value="True"/> 70 | </Win32> 71 | </Options> 72 | </Linking> 73 | </CompilerOptions> 74 | <Debugging> 75 | <Exceptions Count="3"> 76 | <Item1> 77 | <Name Value="EAbort"/> 78 | </Item1> 79 | <Item2> 80 | <Name Value="ECodetoolError"/> 81 | </Item2> 82 | <Item3> 83 | <Name Value="EFOpenError"/> 84 | </Item3> 85 | </Exceptions> 86 | </Debugging> 87 | </CONFIG> 88 | -------------------------------------------------------------------------------- /examples/ses/01/sesdemo.lpr: -------------------------------------------------------------------------------- 1 | program sesdemo; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | {$IFDEF UNIX}{$IFDEF UseCThreads} 7 | cthreads, 8 | {$ENDIF}{$ENDIF} 9 | Interfaces, // this includes the LCL widgetset 10 | Forms, Unit1; 11 | 12 | {$R *.res} 13 | 14 | begin 15 | RequireDerivedFormResource := True; 16 | Application.Initialize; 17 | Application.CreateForm(TForm1, Form1); 18 | Application.Run; 19 | end. 20 | 21 | -------------------------------------------------------------------------------- /examples/ses/01/sesdemo.lps: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectSession> 4 | <Version Value="9"/> 5 | <BuildModes Active="Default"/> 6 | <Units Count="7"> 7 | <Unit0> 8 | <Filename Value="sesdemo.lpr"/> 9 | <IsPartOfProject Value="True"/> 10 | <EditorIndex Value="4"/> 11 | <TopLine Value="2"/> 12 | <CursorPos X="19" Y="6"/> 13 | <UsageCount Value="20"/> 14 | <Loaded Value="True"/> 15 | </Unit0> 16 | <Unit1> 17 | <Filename Value="unit1.lfm"/> 18 | <IsPartOfProject Value="True"/> 19 | <EditorIndex Value="-1"/> 20 | <WindowIndex Value="-1"/> 21 | <TopLine Value="-1"/> 22 | <CursorPos X="-1" Y="-1"/> 23 | <UsageCount Value="20"/> 24 | <DefaultSyntaxHighlighter Value="LFM"/> 25 | </Unit1> 26 | <Unit2> 27 | <Filename Value="unit1.pas"/> 28 | <IsPartOfProject Value="True"/> 29 | <ComponentName Value="Form1"/> 30 | <HasResources Value="True"/> 31 | <ResourceBaseClass Value="Form"/> 32 | <UnitName Value="Unit1"/> 33 | <IsVisibleTab Value="True"/> 34 | <CursorPos X="60" Y="9"/> 35 | <UsageCount Value="20"/> 36 | <Loaded Value="True"/> 37 | <LoadedDesigner Value="True"/> 38 | </Unit2> 39 | <Unit3> 40 | <Filename Value="ses.pas"/> 41 | <ComponentName Value="Form1"/> 42 | <ResourceBaseClass Value="Form"/> 43 | <EditorIndex Value="-1"/> 44 | <TopLine Value="8"/> 45 | <UsageCount Value="20"/> 46 | </Unit3> 47 | <Unit4> 48 | <Filename Value="../../../../erp/components/aws/src/aws_ses.pas"/> 49 | <EditorIndex Value="1"/> 50 | <TopLine Value="16"/> 51 | <CursorPos X="35" Y="20"/> 52 | <UsageCount Value="10"/> 53 | <Loaded Value="True"/> 54 | </Unit4> 55 | <Unit5> 56 | <Filename Value="../../../../erp/components/aws/src/aws_base.pas"/> 57 | <EditorIndex Value="3"/> 58 | <TopLine Value="7"/> 59 | <CursorPos X="3" Y="24"/> 60 | <UsageCount Value="10"/> 61 | <Loaded Value="True"/> 62 | </Unit5> 63 | <Unit6> 64 | <Filename Value="../../../../erp/components/aws/src/aws_client.pas"/> 65 | <EditorIndex Value="2"/> 66 | <TopLine Value="33"/> 67 | <CursorPos X="3" Y="30"/> 68 | <UsageCount Value="10"/> 69 | <Loaded Value="True"/> 70 | </Unit6> 71 | </Units> 72 | <JumpHistory Count="30" HistoryIndex="29"> 73 | <Position1> 74 | <Filename Value="sesdemo.lpr"/> 75 | <Caret Line="9" Column="56"/> 76 | </Position1> 77 | <Position2> 78 | <Filename Value="sesdemo.lpr"/> 79 | <Caret Line="14" Column="10" TopLine="2"/> 80 | </Position2> 81 | <Position3> 82 | <Filename Value="unit1.pas"/> 83 | <Caret Line="8" Column="45" TopLine="4"/> 84 | </Position3> 85 | <Position4> 86 | <Filename Value="../../../../erp/components/aws/src/aws_ses.pas"/> 87 | <Caret Line="68" Column="59" TopLine="58"/> 88 | </Position4> 89 | <Position5> 90 | <Filename Value="../../../../erp/components/aws/src/aws_ses.pas"/> 91 | <Caret Line="79" Column="20" TopLine="70"/> 92 | </Position5> 93 | <Position6> 94 | <Filename Value="unit1.pas"/> 95 | <Caret Line="70" Column="83" TopLine="56"/> 96 | </Position6> 97 | <Position7> 98 | <Filename Value="unit1.pas"/> 99 | <Caret Line="73" Column="43" TopLine="60"/> 100 | </Position7> 101 | <Position8> 102 | <Filename Value="unit1.pas"/> 103 | <Caret Line="54" TopLine="45"/> 104 | </Position8> 105 | <Position9> 106 | <Filename Value="../../../../erp/components/aws/src/aws_ses.pas"/> 107 | <Caret Line="130" Column="12" TopLine="94"/> 108 | </Position9> 109 | <Position10> 110 | <Filename Value="../../../../erp/components/aws/src/aws_ses.pas"/> 111 | <Caret Line="30" Column="3" TopLine="21"/> 112 | </Position10> 113 | <Position11> 114 | <Filename Value="unit1.pas"/> 115 | <Caret Line="71" TopLine="57"/> 116 | </Position11> 117 | <Position12> 118 | <Filename Value="../../../../erp/components/aws/src/aws_ses.pas"/> 119 | <Caret Line="130" Column="12" TopLine="125"/> 120 | </Position12> 121 | <Position13> 122 | <Filename Value="../../../../erp/components/aws/src/aws_ses.pas"/> 123 | <Caret Line="80" Column="56" TopLine="71"/> 124 | </Position13> 125 | <Position14> 126 | <Filename Value="../../../../erp/components/aws/src/aws_ses.pas"/> 127 | <Caret Line="101" Column="67" TopLine="99"/> 128 | </Position14> 129 | <Position15> 130 | <Filename Value="unit1.pas"/> 131 | <Caret Line="73" Column="42" TopLine="58"/> 132 | </Position15> 133 | <Position16> 134 | <Filename Value="unit1.pas"/> 135 | <Caret Line="62" Column="34" TopLine="53"/> 136 | </Position16> 137 | <Position17> 138 | <Filename Value="unit1.pas"/> 139 | <Caret Line="73" TopLine="60"/> 140 | </Position17> 141 | <Position18> 142 | <Filename Value="unit1.pas"/> 143 | <Caret Line="74" TopLine="61"/> 144 | </Position18> 145 | <Position19> 146 | <Filename Value="unit1.pas"/> 147 | <Caret Line="75" TopLine="62"/> 148 | </Position19> 149 | <Position20> 150 | <Filename Value="unit1.pas"/> 151 | <Caret Line="76" TopLine="63"/> 152 | </Position20> 153 | <Position21> 154 | <Filename Value="unit1.pas"/> 155 | <Caret Line="75" TopLine="62"/> 156 | </Position21> 157 | <Position22> 158 | <Filename Value="unit1.pas"/> 159 | <Caret Line="74" TopLine="61"/> 160 | </Position22> 161 | <Position23> 162 | <Filename Value="unit1.pas"/> 163 | <Caret Line="75" TopLine="62"/> 164 | </Position23> 165 | <Position24> 166 | <Filename Value="unit1.pas"/> 167 | <Caret Line="79" Column="39" TopLine="64"/> 168 | </Position24> 169 | <Position25> 170 | <Filename Value="../../../../erp/components/aws/src/aws_ses.pas"/> 171 | <Caret Line="38" Column="59" TopLine="7"/> 172 | </Position25> 173 | <Position26> 174 | <Filename Value="../../../../erp/components/aws/src/aws_client.pas"/> 175 | <Caret Line="163" Column="6" TopLine="148"/> 176 | </Position26> 177 | <Position27> 178 | <Filename Value="unit1.pas"/> 179 | <Caret Line="77" Column="83" TopLine="62"/> 180 | </Position27> 181 | <Position28> 182 | <Filename Value="unit1.pas"/> 183 | <Caret Line="76" Column="45" TopLine="61"/> 184 | </Position28> 185 | <Position29> 186 | <Filename Value="unit1.pas"/> 187 | <Caret Line="58" Column="86" TopLine="65"/> 188 | </Position29> 189 | <Position30> 190 | <Filename Value="unit1.pas"/> 191 | <Caret Line="61" Column="10" TopLine="51"/> 192 | </Position30> 193 | </JumpHistory> 194 | </ProjectSession> 195 | </CONFIG> 196 | -------------------------------------------------------------------------------- /examples/ses/01/sesdemo.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbs99/aws/c39a3d7e3f5cf72951c601ddf961ea215a8c4fcf/examples/ses/01/sesdemo.res -------------------------------------------------------------------------------- /examples/ses/01/unit1.lfm: -------------------------------------------------------------------------------- 1 | object Form1: TForm1 2 | Left = 465 3 | Height = 526 4 | Top = 137 5 | Width = 451 6 | Caption = 'Enviar Email' 7 | ClientHeight = 526 8 | ClientWidth = 451 9 | OnCreate = FormCreate 10 | LCLVersion = '1.4.4.0' 11 | object Button1: TButton 12 | Left = 0 13 | Height = 25 14 | Top = 501 15 | Width = 451 16 | Align = alBottom 17 | Caption = 'Send Email' 18 | OnClick = Button1Click 19 | TabOrder = 8 20 | end 21 | object Label1: TLabel 22 | Left = 11 23 | Height = 17 24 | Top = 8 25 | Width = 89 26 | Caption = 'Access Key Id' 27 | ParentColor = False 28 | end 29 | object edtAcessKeyId: TEdit 30 | Left = 8 31 | Height = 27 32 | Top = 26 33 | Width = 216 34 | TabOrder = 0 35 | end 36 | object edtSecretKey: TEdit 37 | Left = 229 38 | Height = 27 39 | Top = 26 40 | Width = 218 41 | TabOrder = 1 42 | end 43 | object Label2: TLabel 44 | Left = 308 45 | Height = 17 46 | Top = 8 47 | Width = 69 48 | Caption = 'Secret Key' 49 | ParentColor = False 50 | end 51 | object Label3: TLabel 52 | Left = 11 53 | Height = 17 54 | Top = 109 55 | Width = 121 56 | Caption = 'From mail address' 57 | ParentColor = False 58 | end 59 | object edtFromMail: TEdit 60 | Left = 8 61 | Height = 27 62 | Top = 127 63 | Width = 439 64 | TabOrder = 4 65 | end 66 | object Label4: TLabel 67 | Left = 11 68 | Height = 17 69 | Top = 161 70 | Width = 102 71 | Caption = 'To mail address' 72 | ParentColor = False 73 | end 74 | object edtToEmail: TEdit 75 | Left = 8 76 | Height = 27 77 | Top = 179 78 | Width = 439 79 | TabOrder = 5 80 | end 81 | object Label5: TLabel 82 | Left = 11 83 | Height = 17 84 | Top = 212 85 | Width = 57 86 | Caption = 'To Name' 87 | ParentColor = False 88 | end 89 | object edtToName: TEdit 90 | Left = 8 91 | Height = 27 92 | Top = 230 93 | Width = 439 94 | TabOrder = 6 95 | end 96 | object Label6: TLabel 97 | Left = 11 98 | Height = 17 99 | Top = 263 100 | Width = 48 101 | Caption = 'Subject' 102 | ParentColor = False 103 | end 104 | object edtSubject: TEdit 105 | Left = 8 106 | Height = 27 107 | Top = 281 108 | Width = 439 109 | TabOrder = 7 110 | end 111 | object CheckBox1: TCheckBox 112 | Left = 273 113 | Height = 22 114 | Top = 76 115 | Width = 112 116 | Caption = 'HTML Format' 117 | TabOrder = 3 118 | end 119 | object Label8: TLabel 120 | Left = 11 121 | Height = 17 122 | Top = 56 123 | Width = 77 124 | Caption = 'Region AWS' 125 | ParentColor = False 126 | end 127 | object edtRegion: TEdit 128 | Left = 8 129 | Height = 27 130 | Top = 76 131 | Width = 216 132 | TabOrder = 2 133 | end 134 | object PageControl1: TPageControl 135 | Left = 0 136 | Height = 189 137 | Top = 312 138 | Width = 451 139 | ActivePage = TabSheet1 140 | Align = alBottom 141 | TabIndex = 0 142 | TabOrder = 9 143 | object TabSheet1: TTabSheet 144 | Caption = 'Message' 145 | ClientHeight = 154 146 | ClientWidth = 445 147 | object memMessage: TMemo 148 | Left = 0 149 | Height = 154 150 | Top = 0 151 | Width = 445 152 | Align = alClient 153 | ScrollBars = ssAutoBoth 154 | TabOrder = 0 155 | end 156 | end 157 | object TabSheet2: TTabSheet 158 | Caption = 'Response' 159 | ClientHeight = 154 160 | ClientWidth = 445 161 | object memRetorno: TMemo 162 | Left = 0 163 | Height = 154 164 | Top = 0 165 | Width = 445 166 | Align = alClient 167 | ScrollBars = ssAutoBoth 168 | TabOrder = 0 169 | end 170 | end 171 | end 172 | end 173 | -------------------------------------------------------------------------------- /examples/ses/01/unit1.pas: -------------------------------------------------------------------------------- 1 | unit Unit1; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls, 9 | ExtCtrls, ComCtrls, aws_client, aws_ses, aws_credentials, math; 10 | 11 | type 12 | 13 | { TForm1 } 14 | 15 | TForm1 = class(TForm) 16 | Button1: TButton; 17 | CheckBox1: TCheckBox; 18 | edtAcessKeyId: TEdit; 19 | edtRegion: TEdit; 20 | edtFromMail: TEdit; 21 | edtToEmail: TEdit; 22 | edtToName: TEdit; 23 | edtSubject: TEdit; 24 | edtSecretKey: TEdit; 25 | Label1: TLabel; 26 | Label2: TLabel; 27 | Label3: TLabel; 28 | Label4: TLabel; 29 | Label5: TLabel; 30 | Label6: TLabel; 31 | Label8: TLabel; 32 | memMessage: TMemo; 33 | memRetorno: TMemo; 34 | PageControl1: TPageControl; 35 | TabSheet1: TTabSheet; 36 | TabSheet2: TTabSheet; 37 | procedure Button1Click(Sender: TObject); 38 | procedure FormCreate(Sender: TObject); 39 | private 40 | { private declarations } 41 | public 42 | { public declarations } 43 | end; 44 | 45 | var 46 | Form1: TForm1; 47 | 48 | implementation 49 | 50 | {$R *.lfm} 51 | 52 | { TForm1 } 53 | 54 | procedure TForm1.Button1Click(Sender: TObject); 55 | var 56 | oMessage: TSESMessage; 57 | FRegionSES: ISESRegion; 58 | begin 59 | FRegionSES := TSESRegion.New( 60 | TAWSClient.New( 61 | TAWSSignatureVersion3.New(TAWSCredentials.New(edtAcessKeyId.Text, edtSecretKey.Text, True)) 62 | ), edtRegion.Text 63 | ); 64 | 65 | oMessage := TSESMessage.Create; 66 | oMessage.From := edtFromMail.Text; 67 | oMessage.TOAddress:= edtToEmail.Text; 68 | oMessage.TOName:= edtToName.Text; 69 | oMessage.Subject:= edtSubject.Text; 70 | oMessage.Message:= memMessage.Text; 71 | oMessage.Format:=teFormato(ifthen(CheckBox1.Checked, 0, 1)); 72 | 73 | FRegionSES.SESObjects.SendEmail(oMessage).Stream.SaveToFile('retorno.txt'); 74 | 75 | memRetorno.Lines.LoadFromFile('retorno.txt'); 76 | 77 | PageControl1.ActivePage := TabSheet2; 78 | 79 | oMessage.Free; 80 | 81 | end; 82 | 83 | procedure TForm1.FormCreate(Sender: TObject); 84 | begin 85 | PageControl1.ActivePage := TabSheet1; 86 | end; 87 | 88 | end. 89 | 90 | -------------------------------------------------------------------------------- /packages/aws.lpk: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <Package Version="4"> 4 | <PathDelim Value="\"/> 5 | <Name Value="AWS"/> 6 | <Type Value="RunTimeOnly"/> 7 | <Author Value="mdbs99"/> 8 | <CompilerOptions> 9 | <Version Value="11"/> 10 | <PathDelim Value="\"/> 11 | <SearchPaths> 12 | <OtherUnitFiles Value="..\src;..\3rd\synopse"/> 13 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 14 | </SearchPaths> 15 | <Linking> 16 | <Debugging> 17 | <DebugInfoType Value="dsDwarf2Set"/> 18 | </Debugging> 19 | </Linking> 20 | </CompilerOptions> 21 | <Description Value="AWS runtime package."/> 22 | <License Value="See the file LICENSE, included in this distribution, for details about the copyright."/> 23 | <Version Minor="4"/> 24 | <Files Count="15"> 25 | <Item1> 26 | <Filename Value="..\src\aws.inc"/> 27 | <Type Value="Include"/> 28 | </Item1> 29 | <Item2> 30 | <Filename Value="..\src\aws_s3.pas"/> 31 | <UnitName Value="aws_s3"/> 32 | </Item2> 33 | <Item3> 34 | <Filename Value="..\src\aws_client.pas"/> 35 | <UnitName Value="aws_client"/> 36 | </Item3> 37 | <Item4> 38 | <Filename Value="..\src\aws_http.pas"/> 39 | <UnitName Value="aws_http"/> 40 | </Item4> 41 | <Item5> 42 | <Filename Value="..\src\aws_base.pas"/> 43 | <UnitName Value="aws_base"/> 44 | </Item5> 45 | <Item6> 46 | <Filename Value="..\src\aws_credentials.pas"/> 47 | <UnitName Value="aws_credentials"/> 48 | </Item6> 49 | <Item7> 50 | <Filename Value="..\src\aws_ses.pas"/> 51 | <UnitName Value="aws_ses"/> 52 | </Item7> 53 | <Item8> 54 | <Filename Value="..\src\aws_net.pas"/> 55 | <UnitName Value="aws_net"/> 56 | </Item8> 57 | <Item9> 58 | <Filename Value="..\3rd\synopse\syncommons.pas"/> 59 | <UnitName Value="SynCommons"/> 60 | </Item9> 61 | <Item10> 62 | <Filename Value="..\3rd\synopse\syncrypto.pas"/> 63 | <UnitName Value="SynCrypto"/> 64 | </Item10> 65 | <Item11> 66 | <Filename Value="..\3rd\synopse\synfpclinux.pas"/> 67 | <UnitName Value="SynFPCLinux"/> 68 | </Item11> 69 | <Item12> 70 | <Filename Value="..\3rd\synopse\synfpctypinfo.pas"/> 71 | <UnitName Value="SynFPCTypInfo"/> 72 | </Item12> 73 | <Item13> 74 | <Filename Value="..\3rd\synopse\synlz.pas"/> 75 | <UnitName Value="SynLZ"/> 76 | </Item13> 77 | <Item14> 78 | <Filename Value="..\3rd\synopse\Synopse.inc"/> 79 | <Type Value="Include"/> 80 | </Item14> 81 | <Item15> 82 | <Filename Value="..\3rd\synopse\synopsecommit.inc"/> 83 | <Type Value="Include"/> 84 | </Item15> 85 | </Files> 86 | <RequiredPkgs Count="2"> 87 | <Item1> 88 | <PackageName Value="laz_synapse"/> 89 | </Item1> 90 | <Item2> 91 | <PackageName Value="FCL"/> 92 | </Item2> 93 | </RequiredPkgs> 94 | <UsageOptions> 95 | <UnitPath Value="$(PkgOutDir)"/> 96 | </UsageOptions> 97 | <PublishOptions> 98 | <Version Value="2"/> 99 | </PublishOptions> 100 | </Package> 101 | </CONFIG> 102 | -------------------------------------------------------------------------------- /packages/aws.pas: -------------------------------------------------------------------------------- 1 | { This file was automatically created by Lazarus. Do not edit! 2 | This source is only used to compile and install the package. 3 | } 4 | 5 | unit AWS; 6 | 7 | {$warn 5023 off : no warning about unused units} 8 | interface 9 | 10 | uses 11 | aws_s3, aws_client, aws_http, aws_base, aws_credentials, aws_ses, aws_net, 12 | SynCommons, SynCrypto, SynFPCLinux, SynFPCTypInfo, SynLZ; 13 | 14 | implementation 15 | 16 | end. 17 | -------------------------------------------------------------------------------- /src/aws.inc: -------------------------------------------------------------------------------- 1 | { 2 | AWS 3 | Copyright (c) 2013-2018 Marcos Douglas B. Santos 4 | 5 | See the file LICENSE.txt, included in this distribution, 6 | for details about the copyright. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | } 12 | 13 | {$mode objfpc}{$H+} 14 | 15 | -------------------------------------------------------------------------------- /src/aws_base.pas: -------------------------------------------------------------------------------- 1 | { 2 | AWS 3 | Copyright (c) 2013-2018 Marcos Douglas B. Santos 4 | 5 | See the file LICENSE.txt, included in this distribution, 6 | for details about the copyright. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | } 12 | unit aws_base; 13 | 14 | {$i aws.inc} 15 | 16 | interface 17 | 18 | uses 19 | //rtl 20 | classes, 21 | sysutils; 22 | 23 | type 24 | IAWSStream = interface(IInterface) 25 | procedure SaveToStream(Stream: TStream); 26 | procedure SaveToFile(const FileName: string); 27 | function Size: Int64; 28 | end; 29 | 30 | TAWSStream = class sealed(TInterfacedObject, IAWSStream) 31 | private 32 | FStream: TMemoryStream; 33 | public 34 | constructor Create(Stream: TStream); 35 | class function New(Stream: TStream): IAWSStream; 36 | class function New: IAWSStream; 37 | destructor Destroy; override; 38 | procedure SaveToStream(Stream: TStream); 39 | procedure SaveToFile(const FileName: string); 40 | function Size: Int64; 41 | end; 42 | 43 | implementation 44 | 45 | { TAWSStream } 46 | 47 | constructor TAWSStream.Create(Stream: TStream); 48 | begin 49 | FStream := TMemoryStream.Create; 50 | if Assigned(Stream) then 51 | FStream.LoadFromStream(Stream); 52 | end; 53 | 54 | class function TAWSStream.New(Stream: TStream): IAWSStream; 55 | begin 56 | Result := Create(Stream); 57 | end; 58 | 59 | class function TAWSStream.New: IAWSStream; 60 | begin 61 | Result := Create(nil); 62 | end; 63 | 64 | destructor TAWSStream.Destroy; 65 | begin 66 | FStream.Free; 67 | inherited Destroy; 68 | end; 69 | 70 | procedure TAWSStream.SaveToFile(const FileName: string); 71 | begin 72 | FStream.SaveToFile(FileName); 73 | end; 74 | 75 | function TAWSStream.Size: Int64; 76 | begin 77 | Result := FStream.Size; 78 | end; 79 | 80 | procedure TAWSStream.SaveToStream(Stream: TStream); 81 | begin 82 | FStream.SaveToStream(Stream); 83 | end; 84 | 85 | end. 86 | -------------------------------------------------------------------------------- /src/aws_client.pas: -------------------------------------------------------------------------------- 1 | { 2 | AWS 3 | Copyright (c) 2013-2018 Marcos Douglas B. Santos 4 | 5 | See the file LICENSE.txt, included in this distribution, 6 | for details about the copyright. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | } 12 | unit aws_client; 13 | 14 | {$i aws.inc} 15 | 16 | interface 17 | 18 | uses 19 | //rtl 20 | sysutils, 21 | classes, 22 | //synapse 23 | synautil, 24 | //aws 25 | aws_credentials, 26 | aws_http; 27 | 28 | type 29 | IAWSRequest = IHTTPRequest; 30 | 31 | IAWSResponse = IHTTPResponse; 32 | 33 | IAWSClient = interface(IInterface) 34 | ['{9CE71A17-9ADC-4FC1-96ED-8E9C704A988C}'] 35 | function Send(Request: IAWSRequest): IAWSResponse; 36 | end; 37 | 38 | TAWSRequest = THTTPRequest; 39 | 40 | TAWSResponse = THTTPResponse; 41 | 42 | TAWSClient = class sealed(TInterfacedObject, IAWSClient) 43 | private 44 | FSignature: IAWSSignature; 45 | function MakeURL(const SubDomain, Domain, Query: string): string; 46 | public 47 | constructor Create(Signature: IAWSSignature); 48 | class function New(Signature: IAWSSignature): IAWSClient; 49 | function Send(Request: IAWSRequest): IAWSResponse; 50 | end; 51 | 52 | implementation 53 | 54 | { TAWSClient } 55 | 56 | function TAWSClient.MakeURL(const SubDomain, Domain, Query: string): string; 57 | begin 58 | Result := ''; 59 | if FSignature.Credentials.UseSSL then 60 | Result += 'https://' 61 | else 62 | Result += 'http://'; 63 | if SubDomain <> '' then 64 | Result += SubDomain + '.'; 65 | Result += Domain + Query; 66 | end; 67 | 68 | constructor TAWSClient.Create(Signature: IAWSSignature); 69 | begin 70 | inherited Create; 71 | FSignature := Signature; 72 | end; 73 | 74 | class function TAWSClient.New(Signature: IAWSSignature): IAWSClient; 75 | begin 76 | Result := Create(Signature); 77 | end; 78 | 79 | function TAWSClient.Send(Request: IAWSRequest): IAWSResponse; 80 | begin 81 | Result := THTTPSender.New( 82 | Request.Method, 83 | FSignature.Calculate(Request), 84 | Request.ContentType, 85 | MakeURL(Request.SubDomain, Request.Domain, Request.Resource), 86 | Request.Stream 87 | ) 88 | .Send; 89 | end; 90 | 91 | end. 92 | 93 | -------------------------------------------------------------------------------- /src/aws_credentials.pas: -------------------------------------------------------------------------------- 1 | { 2 | AWS 3 | Copyright (c) 2013-2018 Marcos Douglas B. Santos 4 | 5 | See the file LICENSE.txt, included in this distribution, 6 | for details about the copyright. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | } 12 | unit aws_credentials; 13 | 14 | {$i aws.inc} 15 | 16 | interface 17 | 18 | uses 19 | //rtl 20 | sysutils, 21 | classes, 22 | dateutils, 23 | //synapse 24 | synacode, 25 | synautil, 26 | //terceiros 27 | SynCrypto, 28 | //aws 29 | aws_http; 30 | 31 | 32 | type 33 | 34 | IAWSSignatureHMAC256 = interface(IInterface) 35 | ['{9158D9A2-7ABA-4126-9F63-264E947AC60A}'] 36 | function AccessKey: string; 37 | function DataStamp: string; 38 | function RegionName: string; 39 | function ServiceName: string; 40 | function Signature: TSHA256Digest; 41 | end; 42 | 43 | { TAWSSignatureHMAC256 } 44 | 45 | TAWSSignatureHMAC256 = class sealed(TInterfacedObject, IAWSSignatureHMAC256) 46 | private 47 | FAccessKey: string; 48 | FDataStamp: string; 49 | FRegionName: string; 50 | FServiceName: string; 51 | public 52 | constructor Create(const AccessKey, DataStamp, RegionName, ServiceName: string); 53 | class function New(const AccessKey, DataStamp, RegionName, ServiceName: string): IAWSSignatureHMAC256; 54 | function AccessKey: string; 55 | function DataStamp: string; 56 | function RegionName: string; 57 | function ServiceName: string; 58 | function Signature: TSHA256Digest; 59 | end; 60 | 61 | IAWSCredentials = interface(IInterface) 62 | ['{AC6EA523-F2FF-4BD0-8C87-C27E9846FA40}'] 63 | function AccessKeyId: string; 64 | function SecretKey: string; 65 | function UseSSL: Boolean; 66 | end; 67 | 68 | IAWSSignature = interface 69 | function Credentials: IAWSCredentials; 70 | function Calculate(Request: IHTTPRequest): string; 71 | end; 72 | 73 | TAWSCredentials = class sealed(TInterfacedObject, IAWSCredentials) 74 | private 75 | FAccessKeyId: string; 76 | FSecretKey: string; 77 | FSSL: Boolean; 78 | public 79 | constructor Create( 80 | const AccessKeyId, SecretKey: string; 81 | UseSSL: Boolean); reintroduce; 82 | class function New( 83 | const AccessKeyId, SecretKey: string; 84 | UseSSL: Boolean): IAWSCredentials; 85 | function AccessKeyId: string; 86 | function SecretKey: string; 87 | function UseSSL: Boolean; 88 | end; 89 | 90 | TAWSAbstractSignature = class abstract(TInterfacedObject, IAWSSignature) 91 | strict private 92 | FCredentials: IAWSCredentials; 93 | public 94 | constructor Create(Credentials: IAWSCredentials); 95 | class function New(Credentials: IAWSCredentials): IAWSSignature; 96 | function Credentials: IAWSCredentials; 97 | function Calculate(Request: IHTTPRequest): string; virtual; abstract; 98 | end; 99 | 100 | TAWSSignatureVersion1 = class sealed(TAWSAbstractSignature) 101 | public 102 | function Calculate(Request: IHTTPRequest): string; override; 103 | end; 104 | 105 | TAWSSignatureVersion3 = class sealed(TAWSAbstractSignature) 106 | public 107 | function Calculate(Request: IHTTPRequest): string; override; 108 | end; 109 | 110 | { TAWSSignatureVersion4 } 111 | 112 | TAWSSignatureVersion4 = class sealed(TAWSAbstractSignature) 113 | private 114 | function BuildHeader(const Header: String): String; 115 | procedure SignedHeaders(const Header: String; var ToSing, ToCanonical: String); 116 | public 117 | function Calculate(Request: IHTTPRequest): string; override; 118 | end; 119 | 120 | implementation 121 | 122 | { TAWSSignatureHMAC256 } 123 | 124 | constructor TAWSSignatureHMAC256.Create(const AccessKey, DataStamp, 125 | RegionName, ServiceName: string); 126 | begin 127 | inherited Create; 128 | FAccessKey:= AccessKey; 129 | FDataStamp:= DataStamp; 130 | FRegionName:= RegionName; 131 | FServiceName:= ServiceName; 132 | end; 133 | 134 | class function TAWSSignatureHMAC256.New(const AccessKey, DataStamp, 135 | RegionName, ServiceName: string): IAWSSignatureHMAC256; 136 | begin 137 | Result := Create(AccessKey, DataStamp, RegionName, ServiceName); 138 | end; 139 | 140 | function TAWSSignatureHMAC256.AccessKey: string; 141 | begin 142 | Result := FAccessKey; 143 | end; 144 | 145 | function TAWSSignatureHMAC256.DataStamp: string; 146 | begin 147 | Result := FDataStamp; 148 | end; 149 | 150 | function TAWSSignatureHMAC256.RegionName: string; 151 | begin 152 | Result := FRegionName; 153 | end; 154 | 155 | function TAWSSignatureHMAC256.ServiceName: string; 156 | begin 157 | Result := FServiceName; 158 | end; 159 | 160 | function TAWSSignatureHMAC256.Signature: TSHA256Digest; 161 | var 162 | oSHA256: TSHA256Digest; 163 | begin 164 | HMAC_SHA256(UTF8Encode('AWS4'+FAccessKey), UTF8Encode(FDataStamp), oSHA256); 165 | HMAC_SHA256(oSHA256, UTF8Encode(FRegionName), oSHA256); 166 | HMAC_SHA256(oSHA256, UTF8Encode(FServiceName), oSHA256); 167 | HMAC_SHA256(oSHA256, UTF8Encode('aws4_request'), oSHA256); 168 | Result := oSHA256; 169 | end; 170 | 171 | { TAWSSignatureVersion4 } 172 | 173 | function TAWSSignatureVersion4.BuildHeader(const Header: String): String; 174 | var 175 | i: Integer; 176 | List: TStringList; 177 | begin 178 | List := TStringList.Create; 179 | List.Text:=Header; 180 | List.LineBreak:=#10; 181 | List.NameValueSeparator:=':'; 182 | List.Sorted:=True; 183 | List.Sort; 184 | Result := ''; 185 | for i := 1 to List.Count - 1 do 186 | Result := Result + List[i]+#10; 187 | 188 | end; 189 | 190 | procedure TAWSSignatureVersion4.SignedHeaders(const Header: String; var ToSing, ToCanonical: String); 191 | var 192 | i: Integer; 193 | List: TStringList; 194 | Name, Value: String; 195 | begin 196 | List := TStringList.Create; 197 | List.Text:=Header; 198 | List.LineBreak:=#10; 199 | List.NameValueSeparator:=':'; 200 | List.Sorted:=True; 201 | List.Sort; 202 | for i := 1 to List.Count - 1 do 203 | begin 204 | List.GetNameValue(i, Name, Value); 205 | ToSing := ToSing + LowerCase(Name) + ';'; 206 | ToCanonical := ToCanonical + LowerCase(Name)+':'+Value+#10; 207 | end; 208 | system.Delete(ToSing, Length(ToSing), 1); 209 | end; 210 | 211 | function TAWSSignatureVersion4.Calculate(Request: IHTTPRequest): string; 212 | const 213 | Algoritimo = 'AWS4-HMAC-SHA256'; 214 | TipoReq = 'aws4_request'; 215 | var 216 | Header: string; 217 | Credencial: String; 218 | Escopo: String; 219 | DateFmt: String; 220 | AwsDateTime: String; 221 | Metodo: String; 222 | Canonical: String; 223 | CanonicalURI: String; 224 | CanonicalQuery: String; 225 | CanonicalHeaders: String; 226 | SignedHeader: String; 227 | PayLoadHash: String; 228 | CanonicalRequest: String; 229 | StringToSign: String; 230 | Signature: String; 231 | AuthorizationHeader: String; 232 | Assinatura: TSHA256Digest; 233 | oSHA256: TSHA256Digest; 234 | begin 235 | DateFmt:= FormatDateTime('yyyymmdd', IncHour(Now, 3)); 236 | AwsDateTime:= FormatDateTime('yyyymmdd', IncHour(Now, 3))+'T'+FormatDateTime('hhnnss', IncHour(Now, 3))+'Z'; 237 | Metodo:= Request.Method; 238 | CanonicalURI:=EncodeTriplet(Request.Resource, '%', [':']); 239 | CanonicalQuery:=''; 240 | 241 | Header := 'Host:' + Request.Domain + #10 ; 242 | CanonicalHeaders:= 'X-Amz-Date:' + AwsDateTime + #10 + Request.CanonicalizedAmzHeaders + #10; 243 | SignedHeaders(Header+CanonicalHeaders, SignedHeader, Canonical); 244 | 245 | PayLoadHash:= SHA256(Request.SubResource); 246 | 247 | CanonicalRequest := Metodo + #10 + CanonicalURI + #10 + CanonicalQuery + #10 248 | + Canonical + #10 + SignedHeader + #10 + PayLoadHash; 249 | 250 | Credencial:= DateFmt + '/' + Request.ContentMD5 + '/' + Request.CanonicalizedResource + '/' + TipoReq; 251 | Escopo:= Credentials.AccessKeyId + '/' + Credencial; 252 | StringToSign := Algoritimo + #10 + AwsDateTime + #10 + Credencial + #10 + SHA256( UTF8Encode(CanonicalRequest)); 253 | 254 | Assinatura:=TAWSSignatureHMAC256.New(Credentials.SecretKey, DateFmt, Request.ContentMD5, Request.CanonicalizedResource).Signature; 255 | 256 | HMAC_SHA256(Assinatura, UTF8Encode(StringToSign), oSHA256); 257 | Signature := SHA256DigestToString(oSHA256); 258 | 259 | AuthorizationHeader := 'Authorization:' + Algoritimo + ' ' + 'Credential=' + Escopo + ', ' + 260 | 'SignedHeaders=' + SignedHeader + ', ' + 'Signature=' + Signature; 261 | 262 | Result := BuildHeader(CanonicalHeaders) 263 | + AuthorizationHeader 264 | ; 265 | 266 | end; 267 | 268 | { TAWSCredentials } 269 | 270 | constructor TAWSCredentials.Create(const AccessKeyId, SecretKey: string; 271 | UseSSL: Boolean); 272 | begin 273 | FAccessKeyId := AccessKeyId; 274 | FSecretKey := SecretKey; 275 | FSSL := UseSSL; 276 | end; 277 | 278 | class function TAWSCredentials.New(const AccessKeyId, SecretKey: string; 279 | UseSSL: Boolean): IAWSCredentials; 280 | begin 281 | Result := Create(AccessKeyId, SecretKey, UseSSL); 282 | end; 283 | 284 | function TAWSCredentials.AccessKeyId: string; 285 | begin 286 | Result := FAccessKeyId; 287 | end; 288 | 289 | function TAWSCredentials.SecretKey: string; 290 | begin 291 | Result := FSecretKey; 292 | end; 293 | 294 | function TAWSCredentials.UseSSL: Boolean; 295 | begin 296 | Result := FSSL; 297 | end; 298 | 299 | { TAWSAbstractSignature } 300 | 301 | constructor TAWSAbstractSignature.Create(Credentials: IAWSCredentials); 302 | begin 303 | inherited Create; 304 | FCredentials := Credentials; 305 | end; 306 | 307 | class function TAWSAbstractSignature.New( 308 | Credentials: IAWSCredentials): IAWSSignature; 309 | begin 310 | Result := Create(Credentials); 311 | end; 312 | 313 | function TAWSAbstractSignature.Credentials: IAWSCredentials; 314 | begin 315 | Result := FCredentials; 316 | end; 317 | 318 | { TAWSSignatureVersion1 } 319 | 320 | function TAWSSignatureVersion1.Calculate(Request: IHTTPRequest): string; 321 | var 322 | H: string; 323 | DateFmt: string; 324 | begin 325 | DateFmt := RFC822DateTime(Now); 326 | H := Request.Method + #10 327 | + Request.ContentMD5 + #10 328 | + Request.ContentType + #10 329 | + DateFmt + #10; 330 | 331 | if Request.CanonicalizedAmzHeaders <> EmptyStr then 332 | H := H + Request.CanonicalizedAmzHeaders + #10; 333 | 334 | H := H + Request.CanonicalizedResource; 335 | 336 | Result := 'Date: ' + DateFmt + #10; 337 | 338 | if Request.CanonicalizedAmzHeaders <> EmptyStr then 339 | Result := Result + Request.CanonicalizedAmzHeaders + #10; 340 | 341 | Result := Result + 'Authorization: AWS ' 342 | + Credentials.AccessKeyId + ':' 343 | + EncodeBase64(HMAC_SHA1(H, Credentials.SecretKey)) 344 | end; 345 | 346 | { TAWSSignatureVersion3 } 347 | 348 | function TAWSSignatureVersion3.Calculate(Request: IHTTPRequest): string; 349 | var 350 | DateFmt: string; 351 | begin 352 | DateFmt := RFC822DateTime(Now); 353 | Result := 'Date: ' + DateFmt + #10 354 | + 'Host: ' + Request.Domain + #10 355 | + 'X-Amzn-Authorization: ' 356 | + 'AWS3-HTTPS AWSAccessKeyId=' + Credentials.AccessKeyId + ',' 357 | + 'Algorithm=HMACSHA1,Signature='+EncodeBase64(HMAC_SHA1(DateFmt, Credentials.SecretKey)); 358 | end; 359 | 360 | end. 361 | -------------------------------------------------------------------------------- /src/aws_http.pas: -------------------------------------------------------------------------------- 1 | { 2 | AWS 3 | Copyright (c) 2013-2018 Marcos Douglas B. Santos 4 | 5 | See the file LICENSE.txt, included in this distribution, 6 | for details about the copyright. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | } 12 | unit aws_http; 13 | 14 | {$i aws.inc} 15 | 16 | interface 17 | 18 | uses 19 | //rtl 20 | sysutils, 21 | classes, 22 | //synapse 23 | httpsend, 24 | synautil, 25 | ssl_openssl, 26 | //aws 27 | aws_base; 28 | 29 | type 30 | IHTTPRequest = interface(IInterface) 31 | ['{12744C05-22B6-45BF-B47A-49813F6B64B6}'] 32 | function Method: string; 33 | function SubDomain: string; 34 | function Domain: string; 35 | function Resource: string; 36 | function SubResource: string; 37 | function ContentType: string; 38 | function ContentMD5: string; 39 | function CanonicalizedAmzHeaders: string; 40 | function CanonicalizedResource: string; 41 | function Stream: IAWSStream; 42 | function AsString: string; 43 | end; 44 | 45 | IHTTPResponse = interface(IInterface) 46 | ['{6E7E8524-88B5-48B1-95FF-30D0DF40D8F7}'] 47 | function Code: Integer; 48 | function Header: string; 49 | function Text: string; 50 | function Stream: IAWSStream; 51 | end; 52 | 53 | IHTTPSender = interface(IInterface) 54 | ['{DF9B2674-D60C-4F40-AD6A-AE158091212D}'] 55 | function Send: IHTTPResponse; 56 | end; 57 | 58 | THTTPRequest = class sealed(TInterfacedObject, IHTTPRequest) 59 | private 60 | FMethod: string; 61 | FSubDomain: string; 62 | FDomain: string; 63 | FResource: string; 64 | FSubResource: string; 65 | FContentType: string; 66 | FContentMD5: string; 67 | FCanonicalizedAmzHeaders: string; 68 | FCanonicalizedResource: string; 69 | FStream: IAWSStream; 70 | public 71 | constructor Create( 72 | const Method, SubDomain, Domain, Resource, 73 | SubResource, ContentType, ContentMD5, CanonicalizedAmzHeaders, 74 | CanonicalizedResource: string; Stream: IAWSStream 75 | ); 76 | class function New( 77 | const Method, SubDomain, Domain, Resource, 78 | SubResource, ContentType, ContentMD5, CanonicalizedAmzHeaders, 79 | CanonicalizedResource: string; Stream: IAWSStream 80 | ): IHTTPRequest; 81 | class function New( 82 | const Method, SubDomain, Domain, Resource, 83 | SubResource, ContentType, ContentMD5, CanonicalizedAmzHeaders, 84 | CanonicalizedResource: string 85 | ): IHTTPRequest; 86 | class function New( 87 | const Method, SubDomain, Domain, Resource, 88 | SubResource, CanonicalizedResource: string 89 | ): IHTTPRequest; 90 | class function New( 91 | const Method, SubDomain, Domain, Resource, 92 | CanonicalizedResource: string 93 | ): IHTTPRequest; 94 | class function New( 95 | const Method, SubDomain, Domain, Resource, 96 | CanonicalizedResource: string; Stream: IAWSStream 97 | ): IHTTPRequest; 98 | class function New( 99 | const Method, SubDomain, Domain, 100 | CanonicalizedResource: string 101 | ): IHTTPRequest; 102 | function Method: string; 103 | function SubDomain: string; 104 | function Domain: string; 105 | function Resource: string; 106 | function SubResource: string; 107 | function ContentType: string; 108 | function ContentMD5: string; 109 | function CanonicalizedAmzHeaders: string; 110 | function CanonicalizedResource: string; 111 | function Stream: IAWSStream; 112 | function AsString: string; 113 | end; 114 | 115 | THTTPResponse = class sealed(TInterfacedObject, IHTTPResponse) 116 | private 117 | FCode: Integer; 118 | FHeader: string; 119 | FText: string; 120 | FStream: IAWSStream; 121 | public 122 | constructor Create(Code: Integer; const Header, Text: string; Stream: IAWSStream); 123 | class function New(Code: Integer; const Header, Text: string; Stream: IAWSStream): IHTTPResponse; 124 | class function New(Code: Integer; const Header, Text: string): IHTTPResponse; 125 | class function New(Origin: IHTTPResponse): IHTTPResponse; 126 | destructor Destroy; override; 127 | function Code: Integer; 128 | function Header: string; 129 | function Text: string; 130 | function Stream: IAWSStream; 131 | end; 132 | 133 | THTTPSender = class sealed(TInterfacedObject, IHTTPSender) 134 | private 135 | FSender: THTTPSend; 136 | FMethod: string; 137 | FHeader: string; 138 | FContentType: string; 139 | FURL: string; 140 | FStream: IAWSStream; 141 | public 142 | constructor Create(const Method, Header, ContentType, URL: string; Stream: IAWSStream); 143 | class function New(const Method, Header, ContentType, URL: string; Stream: IAWSStream): IHTTPSender; 144 | destructor Destroy; override; 145 | function Send: IHTTPResponse; 146 | end; 147 | 148 | implementation 149 | 150 | { THTTPRequest } 151 | 152 | constructor THTTPRequest.Create(const Method, SubDomain, Domain, Resource, SubResource, 153 | ContentType, ContentMD5, CanonicalizedAmzHeaders, 154 | CanonicalizedResource: string; Stream: IAWSStream); 155 | begin 156 | FMethod := Method; 157 | FSubDomain := SubDomain; 158 | FDomain := Domain; 159 | FResource := Resource; 160 | FSubResource := SubResource; 161 | FContentType := ContentType; 162 | FContentMD5 := ContentMD5; 163 | FCanonicalizedAmzHeaders := CanonicalizedAmzHeaders; 164 | FCanonicalizedResource := CanonicalizedResource; 165 | FStream := Stream 166 | end; 167 | 168 | class function THTTPRequest.New(const Method, SubDomain, Domain, Resource, SubResource, 169 | ContentType, ContentMD5, CanonicalizedAmzHeaders, 170 | CanonicalizedResource: string; Stream: IAWSStream): IHTTPRequest; 171 | begin 172 | Result := Create( 173 | Method, SubDomain, Domain, Resource, SubResource, 174 | ContentType, ContentMD5, CanonicalizedAmzHeaders, 175 | CanonicalizedResource, Stream 176 | ); 177 | end; 178 | 179 | class function THTTPRequest.New(const Method, SubDomain, Domain, Resource, SubResource, 180 | ContentType, ContentMD5, CanonicalizedAmzHeaders, 181 | CanonicalizedResource: string): IHTTPRequest; 182 | begin 183 | Result := New( 184 | Method, SubDomain, Domain, Resource, SubResource, ContentType, 185 | ContentMD5, CanonicalizedAmzHeaders, CanonicalizedResource, 186 | TAWSStream.New 187 | ); 188 | end; 189 | 190 | class function THTTPRequest.New(const Method, SubDomain, Domain, Resource, SubResource, 191 | CanonicalizedResource: string): IHTTPRequest; 192 | begin 193 | Result := New( 194 | Method, SubDomain, Domain, Resource, SubResource, '', 195 | '', '', CanonicalizedResource, 196 | TAWSStream.New 197 | ); 198 | end; 199 | 200 | class function THTTPRequest.New(const Method, SubDomain, Domain, Resource, 201 | CanonicalizedResource: string): IHTTPRequest; 202 | begin 203 | Result := New( 204 | Method, SubDomain, Domain, Resource, '', '', 205 | '', '', CanonicalizedResource, 206 | TAWSStream.New 207 | ); 208 | end; 209 | 210 | class function THTTPRequest.New(const Method, SubDomain, Domain, Resource, 211 | CanonicalizedResource: string; Stream: IAWSStream): IHTTPRequest; 212 | begin 213 | Result := New( 214 | Method, SubDomain, Domain, Resource, '', '', 215 | '', '', CanonicalizedResource, 216 | Stream 217 | ); 218 | end; 219 | 220 | class function THTTPRequest.New(const Method, SubDomain, Domain, 221 | CanonicalizedResource: string): IHTTPRequest; 222 | begin 223 | Result := New( 224 | Method, SubDomain, Domain, '', '', '', 225 | '', '', CanonicalizedResource, 226 | TAWSStream.New 227 | ); 228 | end; 229 | 230 | function THTTPRequest.Method: string; 231 | begin 232 | Result := FMethod; 233 | end; 234 | 235 | function THTTPRequest.SubDomain: string; 236 | begin 237 | Result := FSubDomain; 238 | end; 239 | 240 | function THTTPRequest.Domain: string; 241 | begin 242 | Result := FDomain; 243 | end; 244 | 245 | function THTTPRequest.Resource: string; 246 | begin 247 | Result := FResource; 248 | end; 249 | 250 | function THTTPRequest.SubResource: string; 251 | begin 252 | Result := FSubResource; 253 | end; 254 | 255 | function THTTPRequest.ContentType: string; 256 | begin 257 | Result := FContentType; 258 | end; 259 | 260 | function THTTPRequest.ContentMD5: string; 261 | begin 262 | Result := FContentMD5; 263 | end; 264 | 265 | function THTTPRequest.CanonicalizedAmzHeaders: string; 266 | begin 267 | Result := FCanonicalizedAmzHeaders; 268 | end; 269 | 270 | function THTTPRequest.CanonicalizedResource: string; 271 | begin 272 | Result := FCanonicalizedResource; 273 | end; 274 | 275 | function THTTPRequest.Stream: IAWSStream; 276 | begin 277 | Result := FStream; 278 | end; 279 | 280 | function THTTPRequest.AsString: string; 281 | begin 282 | with TStringList.Create do 283 | try 284 | Add('Method=' + FMethod); 285 | Add('Resource=' + FResource); 286 | Add('SubResource=' + FSubResource); 287 | Add('ContentType=' + FContentType); 288 | Add('ContentMD5=' + FContentMD5); 289 | Add('CanonicalizedAmzHeaders=' + FCanonicalizedAmzHeaders); 290 | Add('CanonicalizedResource=' + FCanonicalizedResource); 291 | Result := Text; 292 | finally 293 | Free; 294 | end; 295 | end; 296 | 297 | { THTTPResponse } 298 | 299 | constructor THTTPResponse.Create(Code: Integer; const Header, Text: string; 300 | Stream: IAWSStream); 301 | begin 302 | inherited Create; 303 | FCode := Code; 304 | FHeader := Header; 305 | FText := Text; 306 | FStream := Stream; 307 | end; 308 | 309 | class function THTTPResponse.New(Code: Integer; const Header, Text: string; 310 | Stream: IAWSStream): IHTTPResponse; 311 | begin 312 | Result := Create(Code, Header, Text, Stream); 313 | end; 314 | 315 | class function THTTPResponse.New(Code: Integer; 316 | const Header, Text: string): IHTTPResponse; 317 | begin 318 | Result := New(Code, Header, Text, nil); 319 | end; 320 | 321 | class function THTTPResponse.New(Origin: IHTTPResponse): IHTTPResponse; 322 | begin 323 | Result := New(Origin.Code, Origin.Header, Origin.Text, Origin.Stream); 324 | end; 325 | 326 | destructor THTTPResponse.Destroy; 327 | begin 328 | inherited Destroy; 329 | end; 330 | 331 | function THTTPResponse.Code: Integer; 332 | begin 333 | Result := FCode; 334 | end; 335 | 336 | function THTTPResponse.Header: string; 337 | begin 338 | Result := FHeader; 339 | end; 340 | 341 | function THTTPResponse.Text: string; 342 | begin 343 | Result := FText; 344 | end; 345 | 346 | function THTTPResponse.Stream: IAWSStream; 347 | begin 348 | Result := FStream; 349 | end; 350 | 351 | { THTTPSender } 352 | 353 | constructor THTTPSender.Create(const Method, Header, ContentType, URL: string; 354 | Stream: IAWSStream); 355 | begin 356 | inherited Create; 357 | FSender := THTTPSend.Create; 358 | FSender.Protocol := '1.0'; 359 | FMethod := Method; 360 | FHeader := Header; 361 | FContentType := ContentType; 362 | FURL := URL; 363 | FStream := Stream; 364 | end; 365 | 366 | class function THTTPSender.New(const Method, Header, ContentType, URL: string; 367 | Stream: IAWSStream): IHTTPSender; 368 | begin 369 | Result := Create(Method, Header, ContentType, URL, Stream); 370 | end; 371 | 372 | destructor THTTPSender.Destroy; 373 | begin 374 | FSender.Free; 375 | inherited Destroy; 376 | end; 377 | 378 | function THTTPSender.Send: IHTTPResponse; 379 | begin 380 | FSender.Clear; 381 | FSender.Headers.Add(FHeader); 382 | FSender.MimeType := FContentType; 383 | FStream.SaveToStream(FSender.Document); 384 | FSender.HTTPMethod(FMethod, FURL); 385 | Result := THTTPResponse.New( 386 | FSender.ResultCode, 387 | FSender.Headers.Text, 388 | FSender.ResultString, 389 | TAWSStream.New(FSender.Document) 390 | ); 391 | end; 392 | 393 | end. 394 | -------------------------------------------------------------------------------- /src/aws_net.pas: -------------------------------------------------------------------------------- 1 | { 2 | AWS 3 | Copyright (c) 2013-2018 Marcos Douglas B. Santos 4 | 5 | See the file LICENSE.txt, included in this distribution, 6 | for details about the copyright. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | } 12 | unit aws_net; 13 | 14 | {$i aws.inc} 15 | 16 | interface 17 | 18 | uses 19 | //rtl 20 | sysutils, 21 | classes; 22 | 23 | type 24 | IAWSURL = interface 25 | function WithSubDomain(const SubDomain: string): IAWSURL; 26 | function WithResource(const Resource: string): IAWSURL; 27 | function AsString: string; 28 | end; 29 | 30 | TAWSURL = class(TInterfacedObject, IAWSURL) 31 | private 32 | FProtocol: string; 33 | FDomain: string; 34 | public 35 | constructor Create(const Protocol, Domain: string); reintroduce; 36 | class function New(const Protocol, Domain: string): IAWSURL; 37 | class function New(const Domain: string): IAWSURL; 38 | function WithSubDomain(const SubDomain: string): IAWSURL; 39 | function WithResource(const Resource: string): IAWSURL; 40 | function AsString: string; 41 | end; 42 | 43 | implementation 44 | 45 | { TAWSURL } 46 | 47 | constructor TAWSURL.Create(const Protocol, Domain: string); 48 | begin 49 | inherited Create; 50 | FProtocol := Protocol; 51 | FDomain := Domain; 52 | end; 53 | 54 | class function TAWSURL.New(const Protocol, Domain: string): IAWSURL; 55 | begin 56 | Result := Create(Protocol, Domain); 57 | end; 58 | 59 | class function TAWSURL.New(const Domain: string): IAWSURL; 60 | begin 61 | Result := New('http', Domain); 62 | end; 63 | 64 | function TAWSURL.WithSubDomain(const SubDomain: string): IAWSURL; 65 | begin 66 | Result := New(FProtocol, SubDomain + '.' + FDomain); 67 | end; 68 | 69 | function TAWSURL.WithResource(const Resource: string): IAWSURL; 70 | begin 71 | Result := New(FProtocol, FDomain + Resource); 72 | end; 73 | 74 | function TAWSURL.AsString: string; 75 | begin 76 | Result := FProtocol + '://' + FDomain; 77 | end; 78 | 79 | end. 80 | -------------------------------------------------------------------------------- /src/aws_s3.pas: -------------------------------------------------------------------------------- 1 | { 2 | AWS 3 | Copyright (c) 2013-2018 Marcos Douglas B. Santos 4 | 5 | See the file LICENSE.txt, included in this distribution, 6 | for details about the copyright. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | } 12 | unit aws_s3; 13 | 14 | {$i aws.inc} 15 | 16 | interface 17 | 18 | uses 19 | //rtl 20 | classes, 21 | sysutils, 22 | //synapse 23 | synautil, 24 | //aws 25 | aws_base, 26 | aws_client; 27 | 28 | const 29 | AWS_S3_URL = 's3.amazonaws.com'; 30 | 31 | type 32 | ES3Error = class(Exception); 33 | 34 | IS3Service = interface; 35 | IS3Bucket = interface; 36 | 37 | IS3Object = interface(IInterface) 38 | ['{FF865D65-97EE-46BC-A1A6-9D9FFE6310A4}'] 39 | function Bucket: IS3Bucket; 40 | function Name: string; 41 | function Stream: IAWSStream; 42 | end; 43 | 44 | IS3Objects = interface(IInterface) 45 | ['{0CDE7D8E-BA30-4FD4-8FC0-F8291131652E}'] 46 | function Get(const ObjectName: string; const SubResources: string): IS3Object; 47 | procedure Delete(const ObjectName: string); 48 | function Put(const ObjectName, ContentType: string; Stream: IAWSStream; const SubResources: string): IS3Object; 49 | function Put(const ObjectName, ContentType, AFileName, SubResources: string): IS3Object; 50 | function Put(const ObjectName, SubResources: string): IS3Object; 51 | function Options(const ObjectName: string): IS3Object; 52 | end; 53 | 54 | IS3Bucket = interface(IInterface) 55 | ['{7E7FA31D-7F54-4BE0-8587-3A72E7D24164}'] 56 | function Name: string; 57 | function Objects: IS3Objects; 58 | end; 59 | 60 | IS3Buckets = interface(IInterface) 61 | ['{8F994521-57A1-4FA6-9F9F-3931E834EFE2}'] 62 | function Check(const BucketName: string): Boolean; 63 | function Get(const BucketName, SubResources: string): IS3Bucket; 64 | procedure Delete(const BucketName, SubResources: string); 65 | function Put(const BucketName, SubResources: string): IS3Bucket; 66 | { TODO : Return a Bucket list } 67 | function All: IAWSResponse; 68 | end; 69 | 70 | IS3Service = interface(IInterface) 71 | ['{B192DB11-4080-477A-80D4-41698832F492}'] 72 | function Online: Boolean; 73 | function Buckets: IS3Buckets; 74 | end; 75 | 76 | TS3Object = class sealed(TInterfacedObject, IS3Object) 77 | private 78 | FBucket: IS3Bucket; 79 | FName: string; 80 | FStream: IAWSStream; 81 | public 82 | constructor Create(Bucket: IS3Bucket; const AName: string; Stream: IAWSStream); 83 | class function New(Bucket: IS3Bucket; const AName: string; Stream: IAWSStream): IS3Object; 84 | function Bucket: IS3Bucket; 85 | function Name: string; 86 | function Stream: IAWSStream; 87 | end; 88 | 89 | TS3Objects = class sealed(TInterfacedObject, IS3Objects) 90 | private 91 | FClient: IAWSClient; 92 | FBucket: IS3Bucket; 93 | public 94 | constructor Create(Client: IAWSClient; Bucket: IS3Bucket); 95 | class function New(Client: IAWSClient; Bucket: IS3Bucket): IS3Objects; 96 | function Get(const ObjectName: string; const SubResources: string): IS3Object; 97 | procedure Delete(const ObjectName: string); 98 | function Put(const ObjectName, ContentType: string; Stream: IAWSStream; const SubResources: string): IS3Object; 99 | function Put(const ObjectName, ContentType, AFileName, SubResources: string): IS3Object; 100 | function Put(const ObjectName, SubResources: string): IS3Object; 101 | function Options(const ObjectName: string): IS3Object; 102 | end; 103 | 104 | TS3Service = class; 105 | 106 | TS3Bucket = class sealed(TInterfacedObject, IS3Bucket) 107 | private 108 | FClient: IAWSClient; 109 | FName: string; 110 | public 111 | constructor Create(Client: IAWSClient; const BucketName: string); 112 | class function New(Client: IAWSClient; const BucketName: string): IS3Bucket; 113 | function Name: string; 114 | function Objects: IS3Objects; 115 | end; 116 | 117 | TS3Buckets = class sealed(TInterfacedObject, IS3Buckets) 118 | private 119 | FClient: IAWSClient; 120 | public 121 | constructor Create(Client: IAWSClient); 122 | class function New(Client: IAWSClient): IS3Buckets; 123 | function Check(const BucketName: string): Boolean; 124 | function Get(const BucketName, SubResources: string): IS3Bucket; 125 | procedure Delete(const BucketName, SubResources: string); 126 | function Put(const BucketName, SubResources: string): IS3Bucket; 127 | function All: IAWSResponse; 128 | end; 129 | 130 | TS3Service = class sealed(TInterfacedObject, IS3Service) 131 | private 132 | FClient: IAWSClient; 133 | public 134 | constructor Create(Client: IAWSClient); 135 | class function New(Client: IAWSClient): IS3Service; 136 | function Online: Boolean; 137 | function Buckets: IS3Buckets; 138 | end; 139 | 140 | implementation 141 | 142 | { TS3Object } 143 | 144 | constructor TS3Object.Create(Bucket: IS3Bucket; const AName: string; 145 | Stream: IAWSStream); 146 | begin 147 | inherited Create; 148 | FBucket := Bucket; 149 | FName := AName; 150 | FStream := Stream; 151 | end; 152 | 153 | class function TS3Object.New(Bucket: IS3Bucket; const AName: string; 154 | Stream: IAWSStream): IS3Object; 155 | begin 156 | Result := Create(Bucket, AName, Stream); 157 | end; 158 | 159 | function TS3Object.Bucket: IS3Bucket; 160 | begin 161 | Result := FBucket; 162 | end; 163 | 164 | function TS3Object.Name: string; 165 | begin 166 | Result := FName; 167 | end; 168 | 169 | function TS3Object.Stream: IAWSStream; 170 | begin 171 | Result := FStream; 172 | end; 173 | 174 | { TS3Objects } 175 | 176 | constructor TS3Objects.Create(Client: IAWSClient; Bucket: IS3Bucket); 177 | begin 178 | inherited Create; 179 | FClient := Client; 180 | FBucket := Bucket; 181 | end; 182 | 183 | class function TS3Objects.New(Client: IAWSClient; Bucket: IS3Bucket): IS3Objects; 184 | begin 185 | Result := Create(Client, Bucket); 186 | end; 187 | 188 | function TS3Objects.Get(const ObjectName: string; const SubResources: string): IS3Object; 189 | begin 190 | with FClient.Send( 191 | TAWSRequest.New( 192 | 'GET', FBucket.Name, AWS_S3_URL, '/' + ObjectName, '/' + FBucket.Name + '/' + ObjectName + SubResources 193 | ) 194 | ) do 195 | begin 196 | if 200 <> Code then 197 | raise ES3Error.CreateFmt('Get error: %d', [Code]); 198 | Result := TS3Object.New(FBucket, ObjectName, Stream); 199 | end; 200 | end; 201 | 202 | procedure TS3Objects.Delete(const ObjectName: string); 203 | begin 204 | with FClient.Send( 205 | TAWSRequest.New( 206 | 'DELETE', FBucket.Name, AWS_S3_URL, '/' + ObjectName, '/' + FBucket.Name + '/' + ObjectName 207 | ) 208 | ) do 209 | begin 210 | if 204 <> Code then 211 | raise ES3Error.CreateFmt('Delete error: %d', [Code]); 212 | end; 213 | end; 214 | 215 | function TS3Objects.Put(const ObjectName, ContentType: string; 216 | Stream: IAWSStream; const SubResources: string): IS3Object; 217 | begin 218 | with FClient.Send( 219 | TAWSRequest.New( 220 | 'PUT', FBucket.Name, AWS_S3_URL, '/' + ObjectName, SubResources, ContentType, '', '', 221 | '/' + FBucket.Name + '/' + ObjectName, Stream 222 | ) 223 | ) do 224 | begin 225 | if 200 <> Code then 226 | raise ES3Error.CreateFmt('Put error: %d', [Code]); 227 | Result := TS3Object.New(FBucket, ObjectName, Stream); 228 | end; 229 | end; 230 | 231 | function TS3Objects.Put(const ObjectName, ContentType, AFileName, 232 | SubResources: string): IS3Object; 233 | var 234 | Buf: TFileStream; 235 | begin 236 | Buf := TFileStream.Create(AFileName, fmOpenRead); 237 | try 238 | Result := Put(ObjectName, ContentType, TAWSStream.New(Buf), SubResources); 239 | finally 240 | Buf.Free; 241 | end; 242 | end; 243 | 244 | function TS3Objects.Put(const ObjectName, SubResources: string): IS3Object; 245 | var 246 | Buf: TMemoryStream; 247 | begin 248 | Buf := TMemoryStream.Create; 249 | try 250 | // hack Synapse to add Content-Length 251 | Buf.WriteBuffer('', 1); 252 | Result := Put(ObjectName, '', TAWSStream.New(Buf), SubResources); 253 | finally 254 | Buf.Free; 255 | end; 256 | end; 257 | 258 | function TS3Objects.Options(const ObjectName: string): IS3Object; 259 | begin 260 | { TODO : Not working properly yet. } 261 | with FClient.Send( 262 | TAWSRequest.New( 263 | 'OPTIONS', FBucket.Name, AWS_S3_URL, '/' + ObjectName, '/' + FBucket.Name + '/' + ObjectName 264 | ) 265 | ) do 266 | begin 267 | if 200 <> Code then 268 | raise ES3Error.CreateFmt('Get error: %d', [Code]); 269 | Result := TS3Object.New(FBucket, ObjectName, Stream); 270 | end; 271 | end; 272 | 273 | { TS3Bucket } 274 | 275 | constructor TS3Bucket.Create(Client: IAWSClient; const BucketName: string); 276 | begin 277 | inherited Create; 278 | FClient := Client; 279 | FName := BucketName; 280 | end; 281 | 282 | class function TS3Bucket.New(Client: IAWSClient; const BucketName: string): IS3Bucket; 283 | begin 284 | Result := Create(Client, BucketName); 285 | end; 286 | 287 | function TS3Bucket.Name: string; 288 | begin 289 | Result := FName; 290 | end; 291 | 292 | function TS3Bucket.Objects: IS3Objects; 293 | begin 294 | Result := TS3Objects.New(FClient, Self); 295 | end; 296 | 297 | { TS3Buckets } 298 | 299 | constructor TS3Buckets.Create(Client: IAWSClient); 300 | begin 301 | inherited Create; 302 | FClient := Client; 303 | end; 304 | 305 | class function TS3Buckets.New(Client: IAWSClient): IS3Buckets; 306 | begin 307 | Result := Create(Client); 308 | end; 309 | 310 | function TS3Buckets.Check(const BucketName: string): Boolean; 311 | begin 312 | Result := FClient.Send( 313 | TAWSRequest.New( 314 | 'HEAD', BucketName, AWS_S3_URL, '', '', '', '', '', '/' + BucketName + '/' 315 | ) 316 | ).Code = 200; 317 | end; 318 | 319 | function TS3Buckets.Get(const BucketName, SubResources: string): IS3Bucket; 320 | begin 321 | with FClient.Send( 322 | TAWSRequest.New( 323 | 'GET', BucketName, AWS_S3_URL, '', SubResources, '', '', '', '/' + BucketName + '/' + SubResources 324 | ) 325 | ) do 326 | begin 327 | if 200 <> Code then 328 | raise ES3Error.CreateFmt('Get error: %d', [Code]); 329 | Result := TS3Bucket.New(FClient, BucketName); 330 | end; 331 | end; 332 | 333 | procedure TS3Buckets.Delete(const BucketName, SubResources: string); 334 | begin 335 | with FClient.Send( 336 | TAWSRequest.New( 337 | 'DELETE', BucketName, AWS_S3_URL, '', SubResources, '', '', '', '/' + BucketName + SubResources 338 | ) 339 | ) do 340 | begin 341 | if 204 <> Code then 342 | raise ES3Error.CreateFmt('Delete error: %d', [Code]); 343 | end; 344 | end; 345 | 346 | function TS3Buckets.Put(const BucketName, SubResources: string): IS3Bucket; 347 | begin 348 | with FClient.Send( 349 | TAWSRequest.New( 350 | 'PUT', BucketName, AWS_S3_URL, '', SubResources, '', '', '', '/' + BucketName + SubResources 351 | ) 352 | ) do 353 | begin 354 | if 200 <> Code then 355 | raise ES3Error.CreateFmt('Put error: %d', [Code]); 356 | Result := TS3Bucket.New(FClient, BucketName); 357 | end; 358 | end; 359 | 360 | function TS3Buckets.All: IAWSResponse; 361 | begin 362 | Result := FClient.Send( 363 | TAWSRequest.New('GET', '', AWS_S3_URL, '', '', '', '', '', '/') 364 | ); 365 | end; 366 | 367 | { TS3Service } 368 | 369 | constructor TS3Service.Create(Client: IAWSClient); 370 | begin 371 | inherited Create; 372 | FClient := Client; 373 | end; 374 | 375 | class function TS3Service.New(Client: IAWSClient): IS3Service; 376 | begin 377 | Result := Create(Client); 378 | end; 379 | 380 | function TS3Service.Online: Boolean; 381 | begin 382 | Result := FClient.Send( 383 | TAWSRequest.New( 384 | 'GET', '', AWS_S3_URL, '', '', '', '', '', '/' 385 | ) 386 | ).Code = 200; 387 | end; 388 | 389 | function TS3Service.Buckets: IS3Buckets; 390 | begin 391 | Result := TS3Buckets.New(FClient); 392 | end; 393 | 394 | end. 395 | -------------------------------------------------------------------------------- /src/aws_ses.pas: -------------------------------------------------------------------------------- 1 | unit aws_ses; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | interface 6 | 7 | uses 8 | //rtl 9 | classes, 10 | sysutils, 11 | //synapse 12 | synautil, 13 | synacode, 14 | //aws 15 | aws_base, 16 | aws_client; 17 | 18 | type 19 | 20 | teFormato = (teHtml, teTexto); 21 | 22 | ISESObjects = Interface; 23 | TSESMessage = class; 24 | 25 | ISESRegion = interface(IInterface) 26 | ['{B72DE2B7-600D-47E1-9CB1-8BE7CBFBB907}'] 27 | function SESObjects: ISESObjects; 28 | end; 29 | 30 | ISESObject = interface(IInterface) 31 | ['{CE161E39-4FA9-46C5-B528-268506DC4740}'] 32 | function Name: string; 33 | function Stream: IAWSStream; 34 | end; 35 | 36 | ISESObjects = interface(IInterface) 37 | ['{FF36521F-A15F-4C98-84DB-4669236F37A8}'] 38 | function SendEmail(Message: TSESMessage): IAWSResponse; 39 | end; 40 | 41 | TSESMessage = class 42 | private 43 | FTOName: String; 44 | FTOAddress: String; 45 | FFrom: String; 46 | FSubject: String; 47 | FFormat: teFormato; 48 | FCharset: String; 49 | FMessage: String; 50 | published 51 | property TOName: String read FTOName write FTOName; 52 | property TOAddress: String read FTOAddress write FTOAddress; 53 | property From: String read FFrom write FFrom; 54 | property Subject: String read FSubject write FSubject; 55 | property Format: teFormato read FFormat write FFormat; 56 | property Charset: String read FCharset write FCharset; 57 | property Message: String read FMessage write FMessage; 58 | end; 59 | 60 | 61 | { TSESRegion } 62 | 63 | TSESRegion = class sealed(TInterfacedObject, ISESRegion) 64 | private 65 | FClient: IAWSClient; 66 | public 67 | constructor Create(Client: IAWSClient; sRegion: String); 68 | class function New(Client: IAWSClient; sRegion: String): ISESRegion; 69 | function SESObjects: ISESObjects; 70 | end; 71 | 72 | { TSESObjects } 73 | 74 | TSESObjects = class sealed(TInterfacedObject, ISESObjects) 75 | private 76 | FClient: IAWSClient; 77 | public 78 | constructor Create(Client: IAWSClient); 79 | class function New(Client: IAWSClient): ISESObjects; 80 | function SendEmail(Message: TSESMessage): IAWSResponse; 81 | end; 82 | 83 | var 84 | sAWS_SES_URL: String; 85 | 86 | implementation 87 | 88 | { TSESObjects } 89 | 90 | constructor TSESObjects.Create(Client: IAWSClient); 91 | begin 92 | inherited Create; 93 | FClient := Client; 94 | end; 95 | 96 | class function TSESObjects.New(Client: IAWSClient): ISESObjects; 97 | begin 98 | Result := Create(Client); 99 | end; 100 | 101 | function TSESObjects.SendEmail(Message: TSESMessage): IAWSResponse; 102 | const 103 | sAnd = '&'; 104 | var 105 | sConteudo: String; 106 | oStream: TStringStream; 107 | oAwsStream: TAWSStream; 108 | begin 109 | 110 | sConteudo:='Action=SendEmail'; 111 | sConteudo:=sConteudo+sAnd+'Destination.ToAddresses.member.1='+EncodeURLElement(Message.TOAddress); 112 | sConteudo:=sConteudo+sAnd+'Source=' +EncodeURLElement(Message.From); 113 | sConteudo:=sConteudo+sAnd+'Message.Subject.Data=' +EncodeURLElement(Message.Subject); 114 | if Message.Format = teHtml then 115 | begin 116 | sConteudo:=sConteudo+sAnd+'Message.Body.Html.Data=' +EncodeURLElement(Message.Message); 117 | if Message.Charset <> EmptyStr then 118 | sConteudo:=sConteudo+sAnd+'Message.Body.Html.Charset=' +EncodeURLElement(Message.Charset); 119 | end 120 | else 121 | begin 122 | sConteudo:=sConteudo+sAnd+'Message.Body.Text.Data=' +EncodeURLElement(Message.Message); 123 | if Message.Charset <> EmptyStr then 124 | sConteudo:=sConteudo+sAnd+'Message.Body.Text.Charset=' +EncodeURLElement(Message.Charset); 125 | end; 126 | 127 | oStream := TStringStream.Create(sConteudo); 128 | oAwsStream := TAWSStream.Create(oStream); 129 | 130 | Result := FClient.Send( 131 | TAWSRequest.New( 132 | 'POST', '', sAWS_SES_URL, '', '/', 'application/x-www-form-urlencoded', 'AWS3', '', '/', oAwsStream) 133 | ); 134 | 135 | oStream.Free; 136 | oAwsStream.Free; 137 | 138 | end; 139 | 140 | { TSESRegion } 141 | 142 | constructor TSESRegion.Create(Client: IAWSClient; sRegion: String); 143 | begin 144 | inherited Create; 145 | FClient := Client; 146 | sAWS_SES_URL:='email.'+sRegion+'.amazonaws.com'; 147 | end; 148 | 149 | class function TSESRegion.New(Client: IAWSClient; sRegion: String): ISESRegion; 150 | begin 151 | Result := Create(Client, sRegion); 152 | end; 153 | 154 | function TSESRegion.SESObjects: ISESObjects; 155 | begin 156 | Result := TSESObjects.Create(FClient); 157 | end; 158 | 159 | end. 160 | 161 | -------------------------------------------------------------------------------- /test/test.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbs99/aws/c39a3d7e3f5cf72951c601ddf961ea215a8c4fcf/test/test.ico -------------------------------------------------------------------------------- /test/test.lpi: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectOptions> 4 | <Version Value="9"/> 5 | <PathDelim Value="\"/> 6 | <General> 7 | <SessionStorage Value="InProjectDir"/> 8 | <MainUnit Value="0"/> 9 | <Title Value="AWSTest"/> 10 | <ResourceType Value="res"/> 11 | <UseXPManifest Value="True"/> 12 | <Icon Value="0"/> 13 | </General> 14 | <i18n> 15 | <EnableI18N LFM="False"/> 16 | </i18n> 17 | <VersionInfo> 18 | <StringTable ProductVersion=""/> 19 | </VersionInfo> 20 | <BuildModes Count="2"> 21 | <Item1 Name="Debug" Default="True"/> 22 | <Item2 Name="Run"> 23 | <CompilerOptions> 24 | <Version Value="11"/> 25 | <PathDelim Value="\"/> 26 | <Target> 27 | <Filename Value="..\bin\test"/> 28 | </Target> 29 | <SearchPaths> 30 | <IncludeFiles Value="$(ProjOutDir)"/> 31 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 32 | </SearchPaths> 33 | <Linking> 34 | <Debugging> 35 | <GenerateDebugInfo Value="False"/> 36 | <UseHeaptrc Value="True"/> 37 | <StripSymbols Value="True"/> 38 | </Debugging> 39 | <Options> 40 | <Win32> 41 | <GraphicApplication Value="True"/> 42 | </Win32> 43 | </Options> 44 | </Linking> 45 | </CompilerOptions> 46 | </Item2> 47 | </BuildModes> 48 | <PublishOptions> 49 | <Version Value="2"/> 50 | <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> 51 | <ExcludeFileFilter Value="*.(bak|ppu|o|so);*~;backup"/> 52 | </PublishOptions> 53 | <RunParams> 54 | <local> 55 | <FormatVersion Value="1"/> 56 | </local> 57 | </RunParams> 58 | <RequiredPackages Count="4"> 59 | <Item1> 60 | <PackageName Value="AWS"/> 61 | </Item1> 62 | <Item2> 63 | <PackageName Value="FPCUnitTestRunner"/> 64 | </Item2> 65 | <Item3> 66 | <PackageName Value="LCL"/> 67 | </Item3> 68 | <Item4> 69 | <PackageName Value="FCL"/> 70 | </Item4> 71 | </RequiredPackages> 72 | <Units Count="3"> 73 | <Unit0> 74 | <Filename Value="test.lpr"/> 75 | <IsPartOfProject Value="True"/> 76 | </Unit0> 77 | <Unit1> 78 | <Filename Value="test_s3.pas"/> 79 | <IsPartOfProject Value="True"/> 80 | </Unit1> 81 | <Unit2> 82 | <Filename Value="test_net.pas"/> 83 | <IsPartOfProject Value="True"/> 84 | </Unit2> 85 | </Units> 86 | </ProjectOptions> 87 | <CompilerOptions> 88 | <Version Value="11"/> 89 | <PathDelim Value="\"/> 90 | <Target> 91 | <Filename Value="..\bin\test"/> 92 | </Target> 93 | <SearchPaths> 94 | <IncludeFiles Value="$(ProjOutDir)"/> 95 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 96 | </SearchPaths> 97 | <Linking> 98 | <Debugging> 99 | <DebugInfoType Value="dsDwarf2Set"/> 100 | <UseHeaptrc Value="True"/> 101 | </Debugging> 102 | <Options> 103 | <Win32> 104 | <GraphicApplication Value="True"/> 105 | </Win32> 106 | </Options> 107 | </Linking> 108 | <Other> 109 | <CustomOptions Value="-dDEB"/> 110 | </Other> 111 | </CompilerOptions> 112 | <Debugging> 113 | <Exceptions Count="3"> 114 | <Item1> 115 | <Name Value="EAbort"/> 116 | </Item1> 117 | <Item2> 118 | <Name Value="ECodetoolError"/> 119 | </Item2> 120 | <Item3> 121 | <Name Value="EFOpenError"/> 122 | </Item3> 123 | </Exceptions> 124 | </Debugging> 125 | </CONFIG> 126 | -------------------------------------------------------------------------------- /test/test.lpr: -------------------------------------------------------------------------------- 1 | program test; 2 | 3 | {$mode objfpc}{$H+} 4 | 5 | uses 6 | Interfaces, Forms, GuiTestRunner, test_s3, test_net; 7 | 8 | {$R *.res} 9 | 10 | begin 11 | Application.Title := 'AWSTest'; 12 | Application.Initialize; 13 | Application.CreateForm(TGuiTestRunner, TestRunner); 14 | Application.Run; 15 | end. 16 | 17 | -------------------------------------------------------------------------------- /test/test.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mdbs99/aws/c39a3d7e3f5cf72951c601ddf961ea215a8c4fcf/test/test.res -------------------------------------------------------------------------------- /test/test_net.pas: -------------------------------------------------------------------------------- 1 | { 2 | AWS 3 | Copyright (c) 2013-2018 Marcos Douglas B. Santos 4 | 5 | See the files COPYING.GH, included in this 6 | distribution, for details about the copyright. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | } 12 | unit test_net; 13 | 14 | {$i ../src/aws.inc} 15 | 16 | interface 17 | 18 | uses 19 | //rtl 20 | classes, 21 | sysutils, 22 | fpcunit, 23 | testregistry, 24 | //aws 25 | aws_net; 26 | 27 | type 28 | TAWSURLTest = class abstract(TTestCase) 29 | published 30 | procedure TestWithSubDomain; 31 | procedure TestWithResource; 32 | end; 33 | 34 | implementation 35 | 36 | { TAWSURLTest } 37 | 38 | procedure TAWSURLTest.TestWithSubDomain; 39 | begin 40 | AssertEquals( 41 | TAWSURL.New('localhost') 42 | .WithSubDomain('subdomain') 43 | .AsString, 44 | 'http://subdomain.localhost' 45 | ); 46 | end; 47 | 48 | procedure TAWSURLTest.TestWithResource; 49 | begin 50 | AssertEquals( 51 | TAWSURL.New('localhost') 52 | .WithResource('/resource') 53 | .AsString, 54 | 'http://localhost/resource' 55 | ); 56 | end; 57 | 58 | initialization 59 | RegisterTest('net', TAWSURLTest); 60 | 61 | end. 62 | 63 | -------------------------------------------------------------------------------- /test/test_s3.pas: -------------------------------------------------------------------------------- 1 | { 2 | AWS 3 | Copyright (c) 2013-2018 Marcos Douglas B. Santos 4 | 5 | See the files COPYING.GH, included in this 6 | distribution, for details about the copyright. 7 | 8 | This program is distributed in the hope that it will be useful, 9 | but WITHOUT ANY WARRANTY; without even the implied warranty of 10 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 11 | } 12 | unit test_s3; 13 | 14 | {$i ../src/aws.inc} 15 | 16 | interface 17 | 18 | uses 19 | //rtl 20 | classes, 21 | sysutils, 22 | fpcunit, 23 | testregistry, 24 | //aws 25 | aws_base, 26 | aws_credentials, 27 | aws_client, 28 | aws_s3; 29 | 30 | type 31 | TAWSFakeClient = class(TInterfacedObject, IAWSClient) 32 | strict private 33 | FRequest: IAWSRequest; 34 | FResponse: IAWSResponse; 35 | public 36 | function Send(Request: IAWSRequest): IAWSResponse; 37 | function Request: IAWSRequest; 38 | function Response: IAWSResponse; 39 | end; 40 | 41 | TS3Test = class abstract(TTestCase) 42 | private 43 | FCredentials: IAWSCredentials; 44 | FClient: IAWSClient; 45 | protected 46 | procedure SetUp; override; 47 | function Client: TAWSFakeClient; 48 | end; 49 | 50 | TS3ServiceTest = class(TS3Test) 51 | published 52 | procedure TestIsOnline; 53 | procedure TestImmutableBuckets; 54 | end; 55 | 56 | TS3BucketsTest = class(TS3Test) 57 | published 58 | procedure TestCheck; 59 | procedure TestGet; 60 | procedure TestDelete; 61 | procedure TestPut; 62 | procedure TestImmutable; 63 | end; 64 | 65 | TS3ObjectsTest = class(TS3Test) 66 | published 67 | procedure TestGet; 68 | procedure TestDelete; 69 | procedure TestPut; 70 | procedure TestOptions; 71 | procedure TestImmutable; 72 | end; 73 | 74 | implementation 75 | 76 | { TAWSFakeClient } 77 | 78 | function TAWSFakeClient.Send(Request: IAWSRequest): IAWSResponse; 79 | var 80 | Code: Integer; 81 | Header, Text: string; 82 | Stream: TStringStream; 83 | begin 84 | FRequest := Request; 85 | Code := -1; 86 | Header := ''; 87 | Text := ''; 88 | case Request.Method of 89 | 'GET', 'HEAD', 'PUT', 'OPTIONS': 90 | begin 91 | Code := 200; 92 | Header := 'HTTP/1.1 200 OK'; 93 | Text := 'OK'; 94 | end; 95 | 'DELETE': 96 | begin 97 | Code := 204; 98 | Header := 'HTTP/1.1 204 No Content'; 99 | Text := 'No Content'; 100 | end; 101 | end; 102 | Stream := TStringStream.Create(Header + #13 + Text); 103 | try 104 | FResponse := TAWSResponse.New( 105 | Code, Header, Text, TAWSStream.New(Stream) 106 | ); 107 | Result := FResponse; 108 | finally 109 | Stream.Free; 110 | end; 111 | end; 112 | 113 | function TAWSFakeClient.Request: IAWSRequest; 114 | begin 115 | Result := FRequest; 116 | end; 117 | 118 | function TAWSFakeClient.Response: IAWSResponse; 119 | begin 120 | Result := FResponse; 121 | end; 122 | 123 | { TS3Test } 124 | 125 | procedure TS3Test.SetUp; 126 | begin 127 | inherited SetUp; 128 | FCredentials := TAWSCredentials.New('dummy_key', 'dummy_secret', False); 129 | FClient := TAWSFakeClient.Create; 130 | end; 131 | 132 | function TS3Test.Client: TAWSFakeClient; 133 | begin 134 | Result := FClient as TAWSFakeClient; 135 | end; 136 | 137 | { TS3ServiceTest } 138 | 139 | procedure TS3ServiceTest.TestIsOnline; 140 | begin 141 | AssertTrue('Service denied', TS3Service.New(FClient).Online); 142 | AssertEquals('GET', Client.Request.Method); 143 | AssertEquals('/', Client.Request.CanonicalizedResource); 144 | end; 145 | 146 | procedure TS3ServiceTest.TestImmutableBuckets; 147 | var 148 | Srv: IS3Service; 149 | begin 150 | Srv := TS3Service.New(FClient); 151 | AssertNotNull('Buckets not alive', Srv.Buckets); 152 | AssertNotSame(Srv.Buckets, Srv.Buckets); 153 | end; 154 | 155 | { TS3BucketsTest } 156 | 157 | procedure TS3BucketsTest.TestCheck; 158 | var 159 | Srv: IS3Service; 160 | begin 161 | Srv := TS3Service.New(FClient); 162 | AssertTrue(Srv.Buckets.Check('myawsbucket')); 163 | AssertEquals('HEAD', Client.Request.Method); 164 | AssertEquals(200, Client.Response.Code); 165 | AssertEquals('HTTP/1.1 200 OK', Client.Response.Header); 166 | AssertEquals('OK', Client.Response.Text); 167 | end; 168 | 169 | procedure TS3BucketsTest.TestGet; 170 | var 171 | Srv: IS3Service; 172 | Bkt: IS3Bucket; 173 | begin 174 | Srv := TS3Service.New(FClient); 175 | Bkt := Srv.Buckets.Get('myawsbucket', ''); 176 | AssertEquals('myawsbucket', Bkt.Name); 177 | AssertEquals('GET', Client.Request.Method); 178 | AssertEquals(200, Client.Response.Code); 179 | AssertEquals('HTTP/1.1 200 OK', Client.Response.Header); 180 | AssertEquals('OK', Client.Response.Text); 181 | end; 182 | 183 | procedure TS3BucketsTest.TestDelete; 184 | var 185 | Srv: IS3Service; 186 | begin 187 | Srv := TS3Service.New(FClient); 188 | Srv.Buckets.Delete('quotes', '/'); 189 | AssertEquals('DELETE', Client.Request.Method); 190 | AssertEquals(204, Client.Response.Code); 191 | AssertEquals('HTTP/1.1 204 No Content', Client.Response.Header); 192 | AssertEquals('No Content', Client.Response.Text); 193 | end; 194 | 195 | procedure TS3BucketsTest.TestPut; 196 | var 197 | Srv: IS3Service; 198 | begin 199 | Srv := TS3Service.New(FClient); 200 | Srv.Buckets.Put('colorpictures', '/'); 201 | AssertEquals('PUT', Client.Request.Method); 202 | AssertEquals(200, Client.Response.Code); 203 | AssertEquals('HTTP/1.1 200 OK', Client.Response.Header); 204 | AssertEquals('OK', Client.Response.Text); 205 | end; 206 | 207 | procedure TS3BucketsTest.TestImmutable; 208 | var 209 | Srv: IS3Service; 210 | Bkt: IS3Bucket; 211 | begin 212 | Srv := TS3Service.New(FClient); 213 | Bkt := Srv.Buckets.Get('myawsbucket', ''); 214 | AssertNotSame(Bkt.Objects, Bkt.Objects); 215 | end; 216 | 217 | { TS3ObjectsTest } 218 | 219 | procedure TS3ObjectsTest.TestGet; 220 | var 221 | Srv: IS3Service; 222 | Bkt: IS3Bucket; 223 | Obj: IS3Object; 224 | begin 225 | Srv := TS3Service.New(FClient); 226 | Bkt := Srv.Buckets.Get('myawsbucket', ''); 227 | Obj := Bkt.Objects.Get('foo.txt', ''); 228 | AssertEquals(200, Client.Response.Code); 229 | AssertEquals('HTTP/1.1 200 OK', Client.Response.Header); 230 | AssertEquals('OK', Client.Response.Text); 231 | AssertTrue('Stream size is zero', Obj.Stream.Size > 0); 232 | end; 233 | 234 | procedure TS3ObjectsTest.TestDelete; 235 | var 236 | Srv: IS3Service; 237 | Bkt: IS3Bucket; 238 | begin 239 | Srv := TS3Service.New(FClient); 240 | Bkt := Srv.Buckets.Get('myawsbucket', ''); 241 | Bkt.Objects.Delete('myobj'); 242 | AssertEquals(204, Client.Response.Code); 243 | AssertEquals('HTTP/1.1 204 No Content', Client.Response.Header); 244 | AssertEquals('No Content', Client.Response.Text); 245 | end; 246 | 247 | procedure TS3ObjectsTest.TestPut; 248 | var 249 | Srv: IS3Service; 250 | Bkt: IS3Bucket; 251 | begin 252 | Srv := TS3Service.New(FClient); 253 | Bkt := Srv.Buckets.Get('myawsbucket', ''); 254 | Bkt.Objects.Put('myobj', 'text/plain', nil, ''); 255 | AssertEquals(200, Client.Response.Code); 256 | AssertEquals('HTTP/1.1 200 OK', Client.Response.Header); 257 | AssertEquals('OK', Client.Response.Text); 258 | end; 259 | 260 | procedure TS3ObjectsTest.TestOptions; 261 | var 262 | Srv: IS3Service; 263 | Bkt: IS3Bucket; 264 | begin 265 | Srv := TS3Service.New(FClient); 266 | Bkt := Srv.Buckets.Get('myawsbucket', ''); 267 | Bkt.Objects.Options('myobj'); 268 | AssertEquals(200, Client.Response.Code); 269 | AssertEquals('HTTP/1.1 200 OK', Client.Response.Header); 270 | AssertEquals('OK', Client.Response.Text); 271 | end; 272 | 273 | procedure TS3ObjectsTest.TestImmutable; 274 | var 275 | Srv: IS3Service; 276 | Bkt: IS3Bucket; 277 | begin 278 | Srv := TS3Service.New(FClient); 279 | Bkt := Srv.Buckets.Get('myawsbucket', ''); 280 | AssertNotSame(Bkt.Objects, Bkt.Objects); 281 | end; 282 | 283 | initialization 284 | RegisterTest('s3.region', TS3ServiceTest); 285 | RegisterTest('s3.buckets', TS3BucketsTest); 286 | RegisterTest('s3.objects', TS3ObjectsTest); 287 | 288 | end. 289 | 290 | --------------------------------------------------------------------------------