forked from rejetto/hfs2
-
Notifications
You must be signed in to change notification settings - Fork 1
/
hslib.pas
1758 lines (1601 loc) · 49.4 KB
/
hslib.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{
Copyright (C) 2002-2020 Massimo Melina (www.rejetto.com)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
HTTP Server Lib
==== TO DO
* https
* upload bandwidth control (can it be done without multi-threading?)
}
{$I- }
unit HSlib;
interface
uses
OverbyteIcsWSocket, classes, messages, winprocs, forms, extctrls, sysutils, system.contnrs, strUtils, winsock, inifiles, types;
const
VERSION = '2.11.0';
type
ThttpSrv=class;
ThttpConn=class;
ThttpMethod=( HM_UNK, HM_GET, HM_POST, HM_HEAD );
ThttpEvent=(
HE_OPEN, // server is listening
HE_CLOSE, // server does not listen anymore
HE_CONNECTED, // a client just connected
HE_DISCONNECTED, // client communication terminated
HE_GOT, // other peer sent sth
HE_SENT, // we sent sth
HE_REQUESTING, // a possible new request starts here
HE_GOT_HEADER, // header part was fully received
HE_REQUESTED, // a full request has been submitted
HE_STREAM_READY, // reply stream ready
HE_REPLIED, // the reply has been sent
HE_POST_FILE, // new file is posted
HE_POST_MORE_FILE, // more data has come for the previous file
HE_POST_END_FILE, // last file done
HE_POST_VARS, // variables are available
HE_POST_VAR, // single variable available
HE_POST_END, // POST section terminated
HE_LAST_BYTE_DONE, // useful to count full downloads
HE_CANT_OPEN_FILE // error
);
ThttpConnState=(
HCS_IDLE, // connected but idle
HCS_REQUESTING, // getting request
HCS_POSTING, // getting post data
HCS_REPLYING, // a reply is pending
HCS_REPLYING_HEADER, // sending header
HCS_REPLYING_BODY, // sending body
HCS_DISCONNECTED // disconnected
);
ThttpReplyMode=(
HRM_REPLY, // reply header+body
HRM_REPLY_HEADER, // reply header only
HRM_DENY, // answer a deny code
HRM_UNAUTHORIZED, // bad user/pwd
HRM_NOT_FOUND, // answer a not-found code
HRM_BAD_REQUEST, // answer a bad-request code
HRM_INTERNAL_ERROR, // answer an internal-error code
HRM_CLOSE, // close connection with no reply
HRM_IGNORE, // does nothing, connection remains open
HRM_METHOD_NOT_ALLOWED, // answer a method-not-allowed code
HRM_REDIRECT, // redirection to another URL
HRM_OVERLOAD, // server is overloaded, retry later
HRM_TOO_LARGE, // the request has exceeded the max length allowed
HRM_MOVED, // moved permanently to another url
HRM_NOT_MODIFIED // use the one in your cache, client
);
ThttpReply = record
mode: ThttpReplyMode;
header: ansistring; // full raw header (optional)
contentType: ansistring; // ContentType header (optional)
additionalHeaders: ansistring; // these are appended to predefined headers (opt)
bodyMode :(
RBM_FILE, // variable body specifies a file
RBM_STRING, // variable body specifies byte content
RBM_STREAM // refer to bodyStream
);
body: ansistring; // specifies reply body according to bodyMode
bodyFile: string;
bodyStream: Tstream; // note: the stream is automatically freed
firstByte, lastByte: int64; // body interval for partial replies (206)
realm, // this will appear in the authentication dialog
reason, // customized reason phrase
url: string; // used for redirections
resumeForbidden: boolean;
end;
ThttpRequest = record
full: ansistring; // the raw request, byte by byte
method: ThttpMethod;
url: ansistring;
ver: ansistring;
firstByte, lastByte: int64; // body interval for partial requests
headers, cookies: ThashedStringList;
user,pwd: string;
end;
ThttpPost = record
length: int64; // multipart form-data length
boundary, // multipart form-data boundary
header, // contextual header
data: ansistring; // misc data
varname, // post variable name
filename: string; // name of posted file
mode: (PM_NONE, PM_URLENCODED, PM_MULTIPART);
end;
TspeedLimiter = class
{ connections can be bound to a limiter. The limiter is a common limited
{ resource (the bandwidth) that is consumed. }
protected
P_maxSpeed: integer; // this is the limit we set. MAXINT means disabled.
procedure setMaxSpeed(v:integer);
public
availableBandwidth: integer; // this is the resource itself
property maxSpeed: integer read P_maxSpeed write setMaxSpeed;
constructor create(max:integer=MAXINT);
end;
ThttpConn = class
protected
srv: ThttpSrv; // reference to the server
stream: Tstream;
P_address: string;
P_port: string;
brecvd: int64; // bytes received from the client
bsent: int64; // bytes sent to the client
bsent_body: int64; // bytes sent to the client (current body only)
bsent_bodies: int64; // bytes sent to the client (for all bodies)
P_requestCount: integer;
P_destroying: boolean; // destroying is in progress
P_sndBuf: integer;
P_v6: boolean;
persistent: boolean;
disconnecting: boolean; // disconnected() has been called
lockCount: integer; // prevent freeing of the object
dontFulFil: boolean;
firstPostFile: boolean;
lastPostItemPos, FbytesPostedLastItem: int64;
// post handling
inBoundaries: boolean; // we are between form-data boundaries
postDataReceived: int64; // bytes received in post data
// used to calculate actual speed
lastBsent, lastBrecvd: int64;
lastSpeedTime: int64;
P_speedOut, P_speedIn: real;
buffer: ansistring; // internal buffer for incoming data
// event handlers
procedure disconnected(Sender: TObject; Error: Word);
procedure dataavailable(Sender: TObject; Error: Word);
procedure senddata(sender:Tobject; bytes:integer);
procedure datasent(sender:Tobject; error:word);
function fullBodySize():int64;
function partialBodySize():int64;
function sendNextChunk(max:integer=MAXINT):integer;
function getBytesToSend():int64;
function getBytesToPost():int64;
function getBytesGot():int64;
procedure notify(ev:ThttpEvent);
procedure tryNotify(ev:ThttpEvent);
procedure calculateSpeed();
procedure sendheader(h:ansistring='');
function replyHeader_mode(mode:ThttpReplyMode):ansistring;
function replyHeader_code(code:integer):ansistring;
function getDontFree():boolean;
procedure processInputBuffer();
procedure clearRequest();
procedure clearReply();
procedure setSndbuf(v:integer);
public
sock: Twsocket; // client-server communication socket
state: ThttpConnState; // what is doing now with this
request: ThttpRequest; // it requests
reply: ThttpReply; // we serve
post: ThttpPost; // it posts
data: pointer; // user data
paused: boolean; // while (not paused) do senddata()
eventData: ansistring;
ignoreSpeedLimit: boolean;
limiters: TobjectList; // every connection can be bound to a number of TspeedLimiter
constructor create(server:ThttpSrv; acceptingSock:Twsocket);
destructor Destroy; override;
procedure disconnect();
procedure addHeader(s:ansistring; overwrite:boolean=TRUE); // set an additional header line. If overwrite=false will always append.
function setHeaderIfNone(s:ansistring):boolean; // set header if not already existing
procedure removeHeader(name:ansistring);
function getHeader(h:ansistring):string; // extract the value associated to the specified header field
function getHeaderA(h:ansistring):ansistring; // extract the value associated to the specified header field
function getCookie(k:string):string;
procedure setCookie(k, v:string; pairs:array of string; extra:string='');
procedure delCookie(k:string);
function getBuffer():ansistring;
function initInputStream():boolean;
property address:string read P_address; // other peer ip address
property port:string read P_port; // other peer port
property v6:boolean read P_v6;
property requestCount:integer read P_requestCount;
property bytesToSend:int64 read getBytesToSend;
property bytesToPost:int64 read getBytesToPost;
property bytesSent:int64 read bsent_bodies;
property bytesSentLastItem:int64 read bsent_body;
property bytesPartial:int64 read partialBodySize;
property bytesFullBody:int64 read fullBodySize;
property bytesGot:int64 read getBytesGot;
property bytesPosted:int64 read postDataReceived;
property bytesPostedLastItem:int64 read FbytesPostedLastItem;
property speedIn:real read P_speedIn; // (bytes_recvd/s)
property speedOut:real read P_speedOut; // (bytes_sent/s)
property disconnectedByServer:boolean read disconnecting;
property destroying:boolean read P_destroying;
property dontFree:boolean read getDontFree;
property getLockCount:integer read lockCount;
property sndBuf:integer read P_sndBuf write setSndBuf;
end;
ThttpSrv = class
protected
timer: Ttimer;
lockTimerevent: boolean;
lastHertz: Tdatetime;
P_port: string;
P_autoFree: boolean;
P_speedIn, P_speedOut: real;
bsent, brecvd: int64;
procedure setPort(v:string);
function getActive():boolean;
procedure setActive(v:boolean);
procedure connected(Sender: TObject; Error: Word);
procedure disconnected(Sender: TObject; Error: Word);
procedure bgexception(Sender: TObject; E:Exception; var CanClose:Boolean);
procedure setAutoFree(v:boolean);
procedure notify(ev:ThttpEvent; conn:ThttpConn);
procedure hertzEvent();
procedure timerEvent(sender:Tobject);
procedure calculateSpeed();
procedure processDisconnecting();
public
sock, sock6: Twsocket; // listening socket
conns, // full list of connected clients
disconnecting, // list of pending disconnections
offlines, // disconnected clients to be freed
q, // clients waiting for data to be sent
limiters: TobjectList;
data: pointer; // user data
persistentConnections: boolean; // if FALSE disconnect clients after they're served
onEvent: procedure(event:ThttpEvent; conn:ThttpConn) of object;
constructor create(); overload;
destructor Destroy(); override;
property active:boolean read getActive write setActive; // r we listening?
property port:string read P_port write setPort;
property bytesSent:int64 read bsent;
property bytesReceived:int64 read brecvd;
property speedIn:real read P_speedIn; // (bytes_recvd/s)
property speedOut:real read P_speedOut; // (bytes_sent/s)
property autoFreeDisconnectedClients: boolean read P_autoFree write setAutoFree;
function start(onAddress:string='*'):boolean; // returns true if all is ok
procedure stop();
procedure disconnectAll(wait:boolean=FALSE);
procedure freeConnList(l:TobjectList);
end;
const
TIMER_HZ = 100;
MINIMUM_CHUNK_SIZE = 2*1024;
MAXIMUM_CHUNK_SIZE = 1024*1024;
HRM2CODE: array [ThttpReplyMode] of integer = (200, 200, 403, 401, 404, 400,
500, 0, 0, 405, 302, 429, 413, 301, 304 );
METHOD2STR: array [ThttpMethod] of ansistring = ('UNK','GET','POST','HEAD');
HRM2STR: array [ThttpReplyMode] of ansistring = ('Head+Body', 'Head only', 'Deny',
'Unauthorized', 'Not found', 'Bad request', 'Internal error', 'Close',
'Ignore', 'Unallowed method', 'Redirect', 'Overload', 'Request too large',
'Moved permanently', 'Not Modified');
{ split S in position where SS is found, the first part is returned
the second part following SS is left in S }
function chop(ss:string; var s:string):string; overload;
function chop(ss:ansistring; var s:ansistring):ansistring; overload;
// same as before, but separator is I
function chop(i:integer; var s:string):string; overload;
// same as before, but specifying separator length
function chop(i, l:integer; var s:string):string; overload;
function chop(i, l:integer; var s:ansistring):ansistring; overload;
// same as chop(lineterminator, s)
function chopLine(var s:string):string; overload;
// decode/decode url
function decodeURL(url:ansistring; utf8:boolean=TRUE):string;
function encodeURL(url:string; nonascii:boolean=TRUE; spaces:boolean=TRUE;
htmlEncoding:boolean=FALSE):string;
// returns true if address is not suitable for the internet
function isLocalIP(ip:string):boolean;
// base64 encoding
function base64encode(s:ansistring):ansistring;
function base64decode(s:ansistring):ansistring;
// an ip address where we are listening
function getIP():string;
// ensure a string ends with a specific string
procedure includeTrailingString(var s:string; ss:string);
// gets unicode code for specified character
function charToUnicode(c:char):dword;
// this version of pos() is able to skip the pattern if inside quotes
function nonQuotedPos(ss, s:string; ofs:integer=1; quote:string='"'; unquote:string='"'):integer;
// case insensitive version
function ipos(ss, s:string; ofs:integer=1):integer; overload;
implementation
uses
Windows, ansistrings;
const
CRLF = #13#10;
HEADER_LIMITER: ansistring = CRLF+CRLF;
MAX_REQUEST_LENGTH = 64*1024;
MAX_INPUT_BUFFER_LENGTH = 256*1024;
// used as body content when the user did not specify any
HRM2BODY: array [ThttpReplyMode] of string = (
'200 - OK',
'200 - OK (header only)',
'403 - You are not allowed to access this file',
'401 - You are not authorized to access this file',
'404 - File not found',
'400 - Bad request',
'500 - Internal server error',
'',
'',
'405 - Method not allowed',
'<html><head><meta http-equiv="refresh" content="url=%url%" /></head><body onload=''window.location="%url%"''>302 - <a href="%url%">Redirection to %url%</a></body></html>',
'429 - Server is overloaded, retry later',
'413 - The request has exceeded the max length allowed',
'301 - Moved permanently to <a href="%url%">%url%</a>',
'' // RFC2616: The 304 response MUST NOT contain a message-body
);
var
freq: int64;
procedure includeTrailingString(var s:string; ss:string); overload;
begin if copy(s, length(s)-length(ss)+1, length(ss)) <> ss then s:=s+ss end;
procedure includeTrailingString(var s:ansistring; ss:ansistring); overload;
begin if copy(s, length(s)-length(ss)+1, length(ss)) <> ss then s:=s+ss end;
function charToUnicode(c:char):dword;
begin stringToWideChar(c,@result,4) end;
function isLocalIP(ip:string):boolean;
var
r: record d,c,b,a:byte end;
begin
if ip = '::1' then
exit(TRUE);
dword(r):=WSocket_ntohl(WSocket_inet_addr(ansiString(ip)));
result:=(r.a in [0,10,23,127])
or (r.a = 192) and ((r.b = 168) or (r.b = 0) and (r.c = 2))
or (r.a = 169) and (r.b = 254)
or (r.a = 172) and (r.b in [16..31])
end; // isLocalIP
function ifThen(c:boolean; a:integer; b:integer=0):integer; overload;
begin if c then result:=a else result:=b end;
function min(a,b:integer):integer;
begin if a < b then result:=a else result:=b end;
function ipos(ss, s: string; ofs:integer=1):integer; overload;
var
rss, rs, rss1, p: pchar;
l: integer;
begin
result:=0;
l:=length(s);
if (l < ofs) or (l = 0) or (ss = '') then exit;
// every strange thing you may notice here is an optimization based on the produced asm
ss:=uppercase(ss);
rss1:=@ss[1];
rs:=@s[ofs];
for result:=ofs to l do
begin
rss:=rss1;
p:=rs;
while (rss^ <> #0) and (rss^ = upcase(p^)) do
begin
inc(rss);
inc(p);
end;
if rss^ = #0 then exit; // we saw it all, and we saw it was good
inc(rs);
end;
result:=0;
end; // ipos
function nonQuotedPos(ss, s:string; ofs:integer=1; quote:string='"'; unquote:string='"'):integer;
var
qpos: integer;
begin
repeat
result:=posEx(ss, s, ofs);
if result = 0 then exit;
repeat
qpos:=posEx(quote, s, ofs);
if qpos = 0 then exit; // there's no quoting, our result will fit
if qpos > result then exit; // the quoting doesn't affect the piece, accept the result
ofs:=posEx(unquote, s, qpos+1);
if ofs = 0 then exit; // it is not closed, we don't consider it quoting
inc(ofs);
until ofs > result; // this quoting was short, let's see if we have another
until false;
end; // nonQuotedPos
// consider using TBase64Encoding.Base64.Encode() in unit netencoding
function base64encode(s:ansistring):ansistring;
const
TABLE:ansistring='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
type
Ttriple=array [0..2] of byte;
var
p: ^Ttriple;
i: integer;
begin
result:='';
p:=@s[1];
for i:=1 to length(s) div 3 do
begin
result:=result+TABLE[1+p[0] shr 2]
+TABLE[1+(p[0] and 3) shl 4+p[1] shr 4]
+TABLE[1+(p[1] and 15) shl 2+p[2] shr 6]
+TABLE[1+(p[2] and 63)];
inc(p);
end;
if length(s) mod 3 = 0 then
exit;
result:=result
+TABLE[1+p[0] shr 2]
+TABLE[1+(p[0] and 3) shl 4+p[1] shr 4];
if length(s) mod 3=1 then
result:=result+'=='
else
result:=result+TABLE[1+(p[1] and 15) shl 2+p[2] shr 6]+'=';
end; // base64encode
function base64decode(s:ansistring):ansistring;
function if_(cond:boolean; c:ansichar):ansistring;
begin
if cond then
result:=c
else
result:=''
end;
const
TABLE:array[#43..#122] of byte=(
62,0,0,0,63,52,53,54,55,56,57,58,59,60,61,0,0,0,0,0,0,0,0,1,2,3,4,5,6,7,
8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,0,0,0,0,0,0,26,27,28,
29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51);
var
i: integer;
p1, p2: byte;
begin
result:='';
i:=1;
while i <= length(s) do
begin
p1:=TABLE[s[i+1]];
p2:=TABLE[s[i+2]];
result:=result
+ansichar(TABLE[s[i]] shl 2+p1 shr 4)
+if_(s[i+2]<>'=', ansichar(p1 shl 4+p2 shr 2))
+if_(s[i+3]<>'=', ansichar(p2 shl 6+TABLE[s[i+3]]));
inc(i,4);
end;
end; // base64decode
function validUTF8(s:rawbytestring):boolean;
var
i, more, len: integer;
c: byte;
begin
len:=length(s);
i:=0;
while i < len do
begin
inc(i);
c:=ord(s[i]);
if c < $80 then
continue;
if c >= $FE then
exit(FALSE);
if c >= $F0 then
more:=3
else if c >= $E0 then
more:=2
else if c >= $C0 then
more:=1
else
exit(FALSE);
if i+more > len then
exit(FALSE);
while more > 0 do
begin
inc(i);
c:=ord(s[i]);
if (c < $80) or (c > $C0) then
exit(FALSE);
dec(more);
end;
end;
result:=TRUE;
end; // validUTF8
function decodeURL(url:ansistring; utf8:boolean=TRUE):string;
var
i, j: integer;
begin
j:=0;
i:=0;
while i<length(url) do
begin
inc(i);
inc(j);
if (url[i] = '%') and (i+2 <= length(url)) then
try
url[j]:=ansichar(strToInt( '$'+url[i+1]+url[i+2] ));
inc(i,2); // three chars for one
except url[j]:='_' end
else if i>j then
url[j]:=url[i];
end;
setLength(url, j);
if utf8 and validUTF8(url) then
begin
result:=utf8ToString(url);
// if the string is not UTF8 compliant, the result is empty, or sometimes same length (but ruined)
if (result='') or (length(result)=length(url)) then
result:=url;
end
else
result:=url;
end; // decodeURL
function encodeURL(url:string; nonascii:boolean=TRUE; spaces:boolean=TRUE;
htmlEncoding:boolean=FALSE):string;
var
i: integer;
encodePerc, encodeHTML: set of char;
a: ansistring;
begin
result:='';
if url = '' then
exit;
encodeHTML:=[];
if nonascii then
encodeHTML:=[#128..#255];
encodePerc:=[#0..#31,'#','%','?','"','''','&','<','>',':',
',',';']; // these for content-disposition
// actually ':' needs encoding only in relative url
if spaces then include(encodePerc,' ');
if not htmlEncoding then
begin
encodePerc:=encodePerc+encodeHTML;
encodeHTML:=[];
end;
if nonascii then
begin
a:=UTF8encode(url); // couldn't find a better way to force url to have the UTF8 encoding
i:=length(a);
setLength(url, i);
for i := 1 to i do
url[i]:=char(a[i]);
end;
for i:=1 to length(url) do
if charInSet(url[i], encodePerc) then
result:=result+'%'+intToHex(ord(url[i]),2)
else if charInSet(url[i], encodeHTML) then
result:=result+'&#'+intToStr(charToUnicode(url[i]))+';'
else
result:=result+url[i];
end; // encodeURL
function getIP():string;
var
i: integer;
ips: Tstrings;
begin
ips:=LocalIPlist();
case ips.count of
0: result:='';
1: result:=ips[0];
else
i:=0;
while (i < ips.count-1) and isLocalIP(ips[i]) do
inc(i);
result:=ips[i];
end;
end; // getIP
function replyHeader_IntPositive(name:ansistring; int:int64):ansistring;
begin
result:='';
if int >= 0 then
result:=name+': '+ansistring(intToStr(int))+CRLF;
end;
function replyHeader_Str(name:ansistring; str:ansistring):ansistring;
begin
result:='';
if str > '' then result:=name+': '+str+CRLF;
end;
function chop(i, l:integer; var s:string):string; overload;
begin
if i=0 then
begin
result:=s;
s:='';
exit;
end;
result:=copy(s,1,i-1);
delete(s,1,i-1+l);
end; // chop
function chop(i, l:integer; var s:ansistring):ansistring; overload;
begin
if i=0 then
begin
result:=s;
s:='';
exit;
end;
result:=copy(s,1,i-1);
delete(s,1,i-1+l);
end; // chop
function chop(ss:string; var s:string):string; overload;
begin result:=chop(pos(ss,s),length(ss),s) end;
function chop(ss:ansistring; var s:ansistring):ansistring; overload;
begin result:=chop(pos(ss,s),length(ss),s) end;
function chop(i:integer; var s:string):string;
begin result:=chop(i,1,s) end;
function chopLine(var s:string):string; overload;
begin
result:=chop(#10,s);
if (result>'') and (result[length(result)]=#13) then
setlength(result, length(result)-1);
end; // chopline
function chopLine(var s:ansistring):ansistring; overload;
begin
result:=chop(#10,s);
if (result>'') and (result[length(result)]=#13) then
setlength(result, length(result)-1);
end; // chopline
/////// SERVER
function ThttpSrv.start(onAddress:string='*'):boolean;
begin
result:=FALSE;
if active or not assigned(sock) then exit;
try
if onAddress = '' then
onAddress:='*';
sock.addr:=ifThen(onAddress = '*', '0.0.0.0', onAddress);
sock.port:=port;
sock.listen();
if port = '0' then
P_port:=sock.getxport();
result:=TRUE;
if onAddress = '*' then
with sock6 do
begin
addr:='::';
Port:=sock.port;
try listen except end;
end;
notify(HE_OPEN, NIL);
except
end;
end; // start
procedure ThttpSrv.stop();
begin
if sock = NIL then exit;
try sock.Close() except end;
try sock6.Close() except end;
end;
procedure ThttpSrv.connected(Sender: TObject; Error: Word);
begin if error=0 then ThttpConn.create(self, sender as Twsocket) end;
procedure ThttpSrv.disconnected(Sender: TObject; Error: Word);
begin notify(HE_CLOSE, NIL) end;
constructor ThttpSrv.create();
begin
sock:=TWSocket.create(NIL);
sock.OnSessionAvailable:=connected;
sock.OnSessionClosed:=disconnected;
sock.OnBgException:=bgexception;
sock6:=TWSocket.create(NIL);
sock6.OnSessionAvailable:=connected;
sock6.OnBgException:=bgexception;
conns:=TobjectList.create;
conns.OwnsObjects:=FALSE;
offlines:=TobjectList.create;
offlines.OwnsObjects:=FALSE;
q:=TobjectList.create;
q.OwnsObjects:=FALSE;
disconnecting:=TobjectList.create;
disconnecting.OwnsObjects:=FALSE;
limiters:=TobjectList.create;
limiters.OwnsObjects:=FALSE;
timer:=Ttimer.create(NIL);
timer.OnTimer:=timerEvent;
timer.Interval:=1000 div TIMER_HZ;
timer.Enabled:=TRUE;
Port:='80';
autoFreeDisconnectedClients:=TRUE;
persistentConnections:=TRUE;
end; // create
destructor ThttpSrv.destroy();
begin
freeAndNIL(timer);
stop();
disconnectAll(TRUE);
processDisconnecting();
freeAndNIL(sock);
freeConnList(conns);
freeAndNIL(conns);
freeAndNIL(disconnecting);
freeAndNIL(offlines);
freeAndNIL(q);
freeAndNIL(limiters);
inherited;
end; // destroy
procedure ThttpSrv.hertzEvent();
var
i: integer;
begin
if now()-lastHertz < 1/(24*60*60) then exit;
lastHertz:=now();
calculateSpeed();
for i:=0 to limiters.Count-1 do
try
with limiters[i] as TspeedLimiter do
availableBandwidth:=maxSpeed;
except end;
end; // hertzEvent
procedure ThttpSrv.processDisconnecting();
var
c: ThttpConn;
i: integer;
begin
i:=0;
while i < disconnecting.Count do
begin
c:=disconnecting[i] as ThttpConn;
inc(i);
if c.dontFree then continue;
c.processInputBuffer(); // serve, till the end.
disconnecting.delete(i-1);
q.remove(c);
conns.remove(c);
offlines.add(c);
notify(HE_DISCONNECTED, c);
end;
end; // processDisconnecting
procedure ThttpSrv.timerEvent(sender:Tobject);
procedure processPipelines();
var
i: integer;
begin
for i:=0 to conns.count-1 do
try
with ThttpConn(conns[i]) do
if (state in [HCS_IDLE, HCS_DISCONNECTED]) and (buffer > '') then
processInputBuffer();
except end;
end; // processPipelines
procedure processQ();
var
c: ThttpConn;
toQ: Tobjectlist;
i, chunkSize: integer;
begin
toQ:=Tobjectlist.create;
try
toQ.ownsObjects:=FALSE;
while q.count > 0 do
begin
c:=NIL;
try
c:=q.first() as ThttpConn; // got an AV here, had no better solution than adding a try statement www.rejetto.com/forum/?topic=6204
q.delete(0);
except end;
if c = NIL then continue;
try
chunkSize:=ifThen(c.paused, 0, MAXINT);
if not c.ignoreSpeedLimit then
for i:=0 to c.limiters.Count-1 do
with c.limiters[i] as TspeedLimiter do
if availableBandwidth >= 0 then
chunkSize:=min(chunkSize, availableBandwidth);
if chunkSize <= 0 then
begin
toQ.add(c);
continue;
end;
if c.destroying or (c.state = HCS_DISCONNECTED)
or (c.sock = NIL) or (c.sock.State <> wsConnected) then
continue;
// serve the pending connection with a data chunk
chunkSize:=c.sendNextChunk(chunkSize);
for i:=0 to c.limiters.Count-1 do
with c.limiters[i] as TspeedLimiter do
dec(availableBandwidth, chunkSize);
except end;
end;
q.assign(toQ, laOR);
finally toQ.Free end;
end; // processQ
begin
hertzEvent();
lockTimerevent:=TRUE;
try
processDisconnecting();
if autoFreeDisconnectedClients then freeConnList(offlines);
processPipelines();
processQ();
finally
lockTimerevent:=FALSE
end;
end; // timerEvent
procedure ThttpSrv.notify(ev:ThttpEvent; conn:ThttpConn);
begin
if not assigned(onEvent) then exit;
if assigned(conn) then
begin
inc(conn.lockCount);
conn.sock.pause();
end;
// event handler shall not break our thing
try onEvent(ev, conn);
finally
//if assigned(sock) then sock.resume();
if assigned(conn) then
begin
dec(conn.lockCount);
conn.sock.resume();
end;
end;
end;
function Thttpsrv.getActive():boolean;
begin result:=assigned(sock) and (sock.State=wsListening) end;
procedure ThttpSrv.setActive(v:boolean);
begin
if v <> active then
if v then start() else stop()
end; // setactive
procedure ThttpSrv.freeConnList(l:TobjectList);
begin
while l.count > 0 do
with l.first() as ThttpConn do
try
try l.delete(0)
finally free end
except end;
end; // freeConnList
procedure ThttpSrv.calculateSpeed();
var
i: integer;
begin
P_speedOut:=0;
P_speedIn:=0;
i:=0;
while i < conns.count do
begin
ThttpConn(conns[i]).calculateSpeed();
P_speedOut:=P_speedOut+ThttpConn(conns[i]).speedOut;
P_speedIn:=P_speedIn+ThttpConn(conns[i]).speedIn;
inc(i);
end;
end; // calculateSpeed
procedure ThttpSrv.setPort(v:string);
begin
if active then
raise Exception.Create(classname+': cannot change port while active');
P_port:=v
end; // setPort
procedure ThttpSrv.disconnectAll(wait:boolean=FALSE);
var
i: integer;
clone: Tlist;
begin
// on disconnection <conns> list changes. clone it for safer enumeration.
clone:=Tlist.Create;
clone.Assign(conns);
// cast disconnection
for i:=0 to clone.count-1 do
ThttpConn(clone[i]).disconnect();
if wait then
for i:=0 to clone.count-1 do
if conns.IndexOf(clone[i]) >= 0 then
ThttpConn(clone[i]).sock.WaitForClose();
clone.free;
end; // disconnectAll
procedure ThttpSrv.setAutoFree(v:boolean);
begin P_autofree:=v end;
procedure ThttpSrv.bgexception(Sender: TObject; E: Exception; var CanClose: Boolean);
begin canClose:=FALSE end;
////////// CLIENT
constructor ThttpConn.create(server:ThttpSrv; acceptingSock:Twsocket);
var
i: integer;
begin
// init socket
sock:=Twsocket.create(NIL);
sock.Dup(acceptingSock.accept());
sock.OnDataAvailable:=dataavailable;
sock.OnSessionClosed:=disconnected;
sock.onSendData:=senddata;
sock.onDataSent:=datasent;
sock.LineMode:=FALSE;
request.headers:=ThashedStringList.create;
request.headers.nameValueSeparator:=':';
limiters:=TObjectList.create;
limiters.ownsObjects:=FALSE;
P_address:=sock.GetPeerAddr();
P_port:=sock.GetPeerPort();
P_v6:=pos(':', address) > 0;
state:=HCS_IDLE;
srv:=server;
srv.conns.add(self);
clearRequest();
clearReply();
QueryPerformanceCounter(lastSpeedTime);
i:=sizeOf(P_sndBuf);
if WSocket_getsockopt(sock.HSocket, SOL_SOCKET, SO_SNDBUF, @P_sndBuf, i) <> NO_ERROR then
P_sndBuf:=0;
server.notify(HE_CONNECTED, self);
if reply.mode <> HRM_CLOSE then exit;
dontFulFil:=TRUE;
disconnect();
end;