GeezerVisonThe World Wide Web, restored to 800 pixels of glory. |
| Home|About|Gaming cabinet|Archives|How it works|Starter sites |
GeezerVison is showing github.com — VisualBasicNetWebServer/ReadHeadersResult.vb at master · BatchedFiles/VisualBasicNetWebServer Expand file tree/ Copy pathReadHeadersResult.vbMore file actions 995 lines (903 loc) · 35.9 KB / Copy pathReadHeadersResult.vbFile metadata and controls995 lines (903 loc) · 35.9 KB 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 ''' <summary> ''' Результат чтения заголовков запроса ''' </summary> <Serializable()> Public Structure ReadHeadersResult Public Class ByteRange Public Start As Long Public Count As Long End Class ''' <summary> ''' Версии протокола http ''' </summary> Public Enum HttpVersions Http11 Http10 Http09 End Enum ''' <summary> ''' Методы Http ''' </summary> Public Enum HttpMethods None HttpGet HttpHead HttpPut HttpPatch HttpDelete HttpPost HttpOptions HttpTrace HttpCopy HttpMove HttpPropfind End Enum ''' <summary> ''' Флаги сжатия содержимого ''' </summary> ''' <remarks></remarks> Public Enum ZipModes ''' <summary> ''' Без сжатия ''' </summary> ''' <remarks></remarks> None ''' <summary> ''' Сжатие Deflate ''' </summary> ''' <remarks></remarks> Deflate ''' <summary> ''' Сжатие GZip ''' </summary> ''' <remarks></remarks> GZip End Enum ''' <summary> ''' Максимальное количество байт в заголовках клиента ''' </summary> Public Const MaxRequestHeaderBytes As Integer = 32 * 1024 ''' <summary> ''' Первая строка запроса клиента ''' </summary> Public RequestLine As String ''' <summary> ''' Байты запроса клиента (заголовок + частично тело) ''' </summary> Public HeaderBytes() As Byte ''' <summary> ''' Количество байт запроса клиента ''' </summary> ''' <remarks></remarks> Public HeaderBytesLength As Integer ''' <summary> ''' Индекс первого байта начала заголовков HTTP (метода, запрошенного ресурса и версии протокола) ''' </summary> Public StartHeadersOffset As Integer ''' <summary> ''' Индекс первого байта после конца заголовков HTTP (конец заголовков + пустая строка) ''' Указывает на начало тела запроса (если оно есть) ''' </summary> Public EndHeadersOffset As Integer ''' <summary> ''' Версия http‐протокола ''' </summary> Public HttpVersion As HttpVersions ''' <summary> ''' Метод HTTP ''' </summary> Public HttpMethod As HttpMethods ''' <summary> ''' Запрошенный клиентом адрес ''' </summary> Public Url As String ''' <summary> ''' Путь, указанный клиентом ''' </summary> ''' <remarks></remarks> Public Path As String ''' <summary> ''' Путь к файлу ''' </summary> ''' <remarks></remarks> Public FilePath As String ''' <summary> ''' Путь к файлу на диске ''' </summary> ''' <remarks></remarks> Public PathTranslated As String '' Это свойство не поддерживается, так как в каталогах может быть точка 'Public PathInfo As String ''' <summary> ''' Строка запроса ''' </summary> Public QueryString As String ''' <summary> ''' Код ответа клиенту ''' </summary> Public StatusCode As Integer ''' <summary> ''' Отправлять клиенту только заголовки ''' </summary> Public SendOnlyHeaders As Boolean ''' <summary> ''' Поддерживать соединение с клиентом ''' </summary> Public KeepAlive As Boolean ''' <summary> ''' Длина тела запроса клиента ''' </summary> Public RequestBodyContentLength As Integer ''' <summary> ''' Строка со всеми заголовками запроса ''' </summary> Public AllRawRequestHeaders As String ' ''' <summary> ' ''' Нераспознанные заголовки запроса ' ''' </summary> Public Const UnknownRequestHeadersMaximum As Integer = 20 Public UnknownRequestHeadersName() As String Public UnknownRequestHeadersValue() As String Public UnknownRequestHeadersCount As Integer ''' <summary> ''' Распознанные заголовки запроса ''' </summary> Public RequestHeaders() As String ''' <summary> ''' Заголовки отправлены клиенту ''' </summary> Public HeadersSent As Boolean ' ''' <summary> ' ''' Заголовки ответа ' ''' </summary> Public ResponseHeaders() As String ''' <summary> ''' Неизвестные заголовки ответа ''' </summary> Public UnknownResponseHeaders As StringBuilder Public LocalIp As String Public RemoteIP As String Public LocalPort As Integer Public IsSecure As Boolean Public ServerName As String ''' <summary> ''' Миме‐типы файлов ''' </summary> Public ContentTypes As List(Of ContentType) ''' <summary> ''' Ёмкость для потока в памяти 100 КиБ, вроде этого должно хватить всем ''' </summary> Public Const MemoryStreamCapacity As Integer = 100 * 1024 ''' <summary> ''' Сжатие данных ''' </summary> Public ZipEnabled As ZipModes ''' <summary> ''' Поток в памяти для записи сжатых данных ''' </summary> Public MemoryStream As MemoryStream ''' <summary> ''' Сжатый поток ''' </summary> Public ZipStream As Stream Public LowerCasedVirtualPath As String Public LowerCasedVirtualPathWithTrailingSlash As String ''' <summary> ''' Объект блокировки и синхронизации ''' </summary> ''' <remarks></remarks> Public LockObject As Object ''' <summary> ''' Коллекция логов сервера ''' </summary> ''' <remarks></remarks> Public Logs As MemoryStream Public WebSites As Dictionary(Of String, WebSite) ''' <summary> ''' Добавляет заголовки компрессии gzip или deflate ''' </summary> ''' <remarks></remarks> Public Sub AddCompressionMethodHeader(ByVal IsText As Boolean) ' Потоки сжатия будут создаваться только при текстовом содержимом If IsText Then If Not String.IsNullOrEmpty(RequestHeaders(HttpWorkerRequest.HeaderAcceptEncoding)) Then Const Deflate As String = "deflate" ' Сжатие трафика If RequestHeaders(HttpWorkerRequest.HeaderAcceptEncoding).Contains(Deflate) Then ZipEnabled = ZipModes.Deflate ResponseHeaders(HttpWorkerRequest.HeaderContentEncoding) = Deflate MemoryStream = New MemoryStream(ReadHeadersResult.MemoryStreamCapacity) ZipStream = New IO.Compression.DeflateStream(MemoryStream, Compression.CompressionMode.Compress, True) Else Const Gzip As String = "gzip" If RequestHeaders(HttpWorkerRequest.HeaderAcceptEncoding).Contains(Gzip) Then ZipEnabled = ZipModes.GZip ResponseHeaders(HttpWorkerRequest.HeaderContentEncoding) = Gzip MemoryStream = New MemoryStream(ReadHeadersResult.MemoryStreamCapacity) ZipStream = New IO.Compression.GZipStream(MemoryStream, Compression.CompressionMode.Compress, True) End If End If End If Else ZipEnabled = ZipModes.None ResponseHeaders(HttpWorkerRequest.HeaderContentEncoding) = Nothing End If End Sub ''' <summary> ''' Добавляет заголовки кеширования для файла и проверяет совпадение на заголовки кэширования ''' </summary> ''' <remarks></remarks> Public Sub AddCacheHeaders() ' Проверить ETag, если совпадает, вернуть, что не изменилось 'If-None-Match: "686897696a7c876b7e" '304 Not Modified ' Ещё для кеширования 'Last-Modified и If-Modified-Since '304 Not Modified Dim f As New FileInfo(PathTranslated) ' Дата последней модицикации и контрольная сумма Dim dFileLastModified As Date = f.LastWriteTimeUtc ' ETag для сжатого и несжатого содержимого должен быть разным Dim ETag As String = If(f.Exists, """" & f.LastWriteTime.ToBinary.ToString & If(ZipEnabled = ZipModes.GZip, "gzip""", If(ZipEnabled = ZipModes.Deflate, "deflate""", """")), String.Empty) Dim strClientDate = RequestHeaders(HttpWorkerRequest.HeaderIfModifiedSince) Dim bModified As Boolean = True If String.IsNullOrEmpty(strClientDate) Then bModified = True Else Dim ClientDate As Date ' Убрать UTC и заменить на GMT 'If-Modified-Since: Thu, 24 Mar 2016 16:10:31 UTC 'If-Modified-Since: Tue, 11 Mar 2014 20:07:57 GMT Dim blnResult As Boolean = Date.TryParse(strClientDate.Replace("UTC", "GMT").Split(";"c)(0), ClientDate) If blnResult Then If ClientDate.ToLocalTime < New Date(dFileLastModified.Year, dFileLastModified.Month, dFileLastModified.Day, dFileLastModified.Hour, dFileLastModified.Minute, dFileLastModified.Second) Then bModified = True Else bModified = False End If Else bModified = True End If End If If bModified Then If Not String.IsNullOrEmpty(RequestHeaders(HttpWorkerRequest.HeaderIfNoneMatch)) Then bModified = (RequestHeaders(HttpWorkerRequest.HeaderIfNoneMatch) <> ETag) End If End If SendOnlyHeaders = SendOnlyHeaders OrElse Not bModified ResponseHeaders(HttpWorkerRequest.HeaderLastModified) = dFileLastModified.ToString("R", DateTimeFormatInfo.InvariantInfo) ResponseHeaders(HttpWorkerRequest.HeaderEtag) = ETag ResponseHeaders(HttpWorkerRequest.HeaderCacheControl) = "max-age=2678400" ' Целый месяц кэширования StatusCode = If(bModified, 200, 304) End Sub ''' <summary> ''' Добавляет заголовок в заголовки запроса клиента ''' </summary> ''' <param name="Header"></param> ''' <param name="Value"></param> ''' <returns>Возвращает True, если заголовок Host был пустым</returns> ''' <remarks></remarks> Public Function AddRequestHeader(ByVal Header As String, ByVal Value As String) As Boolean Dim knownIndex As Integer = HttpWorkerRequest.GetKnownRequestHeaderIndex(Header) If knownIndex >= 0 Then ' Дополнительные действия по заголовкам запроса Select Case knownIndex Case HttpWorkerRequest.HeaderConnection ' Поддержка соединения If Value.ToLower.Contains("close") Then KeepAlive = False Else If Value.ToLower.Contains("keep-alive") Then KeepAlive = True End If End If Case HttpWorkerRequest.HeaderAcceptEncoding Case HttpWorkerRequest.HeaderHost ' Заголовок Host, он же имя сайта If Value.Length = 0 Then Return True End If End Select RequestHeaders(knownIndex) = Value Else ' Добавить в нераспознанные заголовки If UnknownRequestHeadersCount < UnknownRequestHeadersMaximum Then UnknownRequestHeadersName(UnknownRequestHeadersCount) = Header UnknownRequestHeadersValue(UnknownRequestHeadersCount) = Value UnknownRequestHeadersCount += 1 End If End If Return False End Function ''' <summary> ''' Добавляет заголовок в заголовки ответа сервера ''' </summary> ''' <param name="Header"></param> ''' <param name="Value"></param> ''' <remarks></remarks> Public Sub AddResponseHeader(ByVal Header As String, ByVal Value As String) Dim knownIndex As Integer = HttpWorkerRequest.GetKnownResponseHeaderIndex(Header) If knownIndex >= 0 Then ResponseHeaders(knownIndex) = Value Else UnknownResponseHeaders.AppendLine(Header & ": " & Value) End If End Sub Public Function GetBytesRange(ByVal FileLength As Long) As List(Of ByteRange) ' Нужно проверить частичный запрос Dim result As New List(Of ByteRange) If String.IsNullOrEmpty(RequestHeaders(HttpWorkerRequest.HeaderRange)) Then ' Выдать всё содержимое от начала до конца result.Add(New ByteRange With {.Count = FileLength}) Else ' Выдать только диапазон If RequestHeaders(HttpWorkerRequest.HeaderRange).StartsWith("bytes=") Then Dim c As Integer = RequestHeaders(HttpWorkerRequest.HeaderRange).IndexOf("=") If c > 0 Then Dim value As String = RequestHeaders(HttpWorkerRequest.HeaderRange).Substring(c + 1) If value.Length > 0 Then 'bytes=0-255 — фрагмент от 0-го до 255-го байта включительно. 'bytes=42-42 — запрос одного 42-го байта. 'bytes=4000-7499,1000-2999 — два фрагмента. Так как первый выходит за пределы, то он интерпретируется как «4000-4999». 'bytes=3000-,6000-8055 — первый интерпретируется как «3000-4999», а второй игнорируется. 'bytes=-400,-9000 — последние 400 байт (от 4600 до 4999), а второй подгоняется под рамки содержимого (от 0 до 4999) обозначая как фрагмент весь объём. 'bytes=500-799,600-1023,800-849 — при пересечениях диапазоны могут объединяться в один (от 500 до 1023). For Each range As String In value.Split(","c) c = range.IndexOf("=") If c >= 0 Then ' Начало Dim nStart As Long Long.TryParse(range.Substring(0, c), nStart) ' Конец Dim nEnd As Long Long.TryParse(range.Substring(c + 1), nEnd) End If Next End If End If End If End If Return result End Function Public Sub SetHttpMethod(ByVal method As String) Select Case method Case "COPY" HttpMethod = HttpMethods.HttpCopy Case "DELETE" HttpMethod = HttpMethods.HttpDelete Case "GET" HttpMethod = HttpMethods.HttpGet Case "HEAD" HttpMethod = HttpMethods.HttpHead Case "MOVE" HttpMethod = HttpMethods.HttpMove Case "OPTIONS" HttpMethod = HttpMethods.HttpOptions Case "PATCH" HttpMethod = HttpMethods.HttpPatch Case "POST" HttpMethod = HttpMethods.HttpPost Case "PROPFIND" HttpMethod = HttpMethods.HttpPropfind Case "PUT" HttpMethod = HttpMethods.HttpPut Case "TRACE" HttpMethod = HttpMethods.HttpTrace End Select End Sub Public Function GetHttpMethodString() As String Select Case HttpMethod Case HttpMethods.HttpGet Return "GET" Case HttpMethods.HttpHead Return "HEAD" Case HttpMethods.HttpPut Return "PUT" Case HttpMethods.HttpPatch Return "PATCH" Case HttpMethods.HttpDelete Return "DELETE" Case HttpMethods.HttpPost Return "POST" Case HttpMethods.HttpOptions Return "OPTIONS" Case HttpMethods.HttpTrace Return "TRACE" Case HttpMethods.HttpCopy Return "COPY" Case HttpMethods.HttpMove Return "MOVE" Case HttpMethods.HttpPropfind Return "PROPFIND" Case Else Return String.Empty End Select End Function Public Function ReadLine(ByVal objStream As Stream) As String ' Найти в буфере vbCrLf Dim FindIndex As Integer = FindCrLf(HeaderBytes, EndHeadersOffset, HeaderBytesLength) Dim line As String Do While FindIndex = -1 ' Символы переноса строки не найдены ' Если буфер заполнен, то считывать данные больше нельзя If HeaderBytesLength >= ReadHeadersResult.MaxRequestHeaderBytes Then Return Nothing Else ' Считать данные Dim numReceived As Integer Try numReceived = objStream.Read(HeaderBytes, HeaderBytesLength, ReadHeadersResult.MaxRequestHeaderBytes - HeaderBytesLength) Catch ex As Exception Return Nothing End Try If numReceived = 0 Then ' Если в буфере что‐то было? If EndHeadersOffset < HeaderBytesLength Then line = Encoding.ASCII.GetString(HeaderBytes, EndHeadersOffset, HeaderBytesLength - EndHeadersOffset) ' Поставить конец заголовков за пределы полученных байт EndHeadersOffset = HeaderBytesLength Return line Else Return Nothing End If Else ' Сколько байт получили, на столько и увеличили буфер HeaderBytesLength += numReceived ' Найти vbCrLf опять FindIndex = FindCrLf(HeaderBytes, EndHeadersOffset, HeaderBytesLength) End If End If Debug.WriteLine("Выполняю ReadLine") Loop ' Найдено, получить строку line = Encoding.ASCII.GetString(HeaderBytes, EndHeadersOffset, FindIndex - EndHeadersOffset) ' Сдвинуть конец заголовков вправо на FindIndex + len(vbCrLf) EndHeadersOffset = FindIndex + 2 Return line End Function ''' <summary> ''' Читает запрос клиента ''' </summary> ''' <param name="objStream">Клиентский поток</param> ''' <remarks></remarks> Public Function ReadAllHeaders(ByVal objStream As Stream) As ParseRequestLineResult ' Проверить наличие данных от клиента RequestLine = ReadLine(objStream) If RequestLine Is Nothing Then Return ParseRequestLineResult.EmptyRequest End If ' Метод, запрошенный ресурс и версия протокола Dim HttpMethods() As String = RequestLine.Split Select Case HttpMethods.Length Case 2 HttpVersion = ReadHeadersResult.HttpVersions.Http09 Case 3 Select Case HttpMethods(2) Case "HTTP/1.0" HttpVersion = ReadHeadersResult.HttpVersions.Http10 Case "HTTP/1.1" HttpVersion = ReadHeadersResult.HttpVersions.Http11 KeepAlive = True ' Для версии 1.1 это по умолчанию Case Else ' Протокол не поддерживается Return ParseRequestLineResult.HTTPVersionNotSupported End Select Case Else Return ParseRequestLineResult.BadRequest End Select ' Проверить поддерживаемый метод SetHttpMethod(HttpMethods(0)) If HttpMethod = ReadHeadersResult.HttpMethods.None Then Return ParseRequestLineResult.MethodNotSupported End If ' Начало заголовков StartHeadersOffset = EndHeadersOffset ' Отправлять только заголовки SendOnlyHeaders = (HttpMethod = ReadHeadersResult.HttpMethods.HttpHead) ' Запрошенный клиентом ресурс Url = HttpMethods(1) ' Получить все заголовки запроса Do Dim line As String = ReadLine(objStream) If line Is Nothing Then ' Ошибка, строка не должна быть Nothing Return ParseRequestLineResult.EmptyRequest Else If line.Length = 0 Then ' Клиент отправил все данные, можно приступать к обработке Exit Do Else 'UNDONE Обработать ситуацию, когда клиент отправляет заголовок с переносом на новую строку Dim c As Integer = line.IndexOf(":"c) If c > 0 Then Dim name As String = line.Substring(0, c) Dim value As String = line.Substring(c + 1).Trim() If AddRequestHeader(name, value) Then Return ParseRequestLineResult.HostRequired End If End If End If End If Loop ' Проверить заголовок Host If String.IsNullOrEmpty(RequestHeaders(HttpWorkerRequest.HeaderHost)) Then Return ParseRequestLineResult.HostRequired End If ' Запомнить все заголовки в одну сплошную строку AllRawRequestHeaders = Encoding.ASCII.GetString(HeaderBytes, StartHeadersOffset, EndHeadersOffset - StartHeadersOffset) Return ParseRequestLineResult.Success End Function ''' <summary> ''' Разбор отправленного клиентом содержимого ''' </summary> ''' <remarks></remarks> Public Function ParsePostedContent() As ClientConnection.ParsePostedContentResult If String.IsNullOrEmpty(RequestHeaders(HttpWorkerRequest.HeaderContentLength)) Then ' Требуется указание длины Return ParsePostedContentResult.LengthRequired End If ' Длина содержимого по заголовку Content-Length If Integer.TryParse(RequestHeaders(HttpWorkerRequest.HeaderContentLength), RequestBodyContentLength) Then ' Не больше четырёх метров If RequestBodyContentLength > 4194304 Then Return ParsePostedContentResult.RequestEntityTooLarge End If Return ParsePostedContentResult.None Else ' Плохой запрос Return ParsePostedContentResult.BadRequest End If End Function ''' <summary> ''' Проверяет авторизацию Http ''' </summary> ''' <param name="objStream"></param> ''' <param name="UsersFile"></param> ''' <param name="VirtualPath"></param> ''' <returns>Возвращает True, если авторизация не прошла</returns> ''' <remarks></remarks> Public Function HttpAuth(ByVal objStream As Stream, ByVal UsersFile As String, ByVal VirtualPath As String) As Boolean ' Проверка заголовка Authorization If String.IsNullOrEmpty(RequestHeaders(HttpWorkerRequest.HeaderAuthorization)) Then ' Требуется авторизация StatusCode = 401 ResponseHeaders(HttpWorkerRequest.HeaderWwwAuthenticate) = "Basic realm=""Need username and password""" WriteError(objStream, "Требуется логин и пароль для доступа", VirtualPath) Return True Else Dim sAuth = RequestHeaders(HttpWorkerRequest.HeaderAuthorization).Split If sAuth.Length > 1 Then If sAuth(0) = "Basic" Then ' Расшифровать Dim UsernamePassword As String = Encoding.ASCII.GetString(Convert.FromBase64String(sAuth(1))) ' Проверить имя пользователя и пароль 'Dim NamePass() As String = UsernamePassword.Split(":c") Dim q = From s As String In File.ReadAllLines(UsersFile) Where s = UsernamePassword If q.Count = 0 Then ' Ошибка 401 ' Имя пользователя и пароль не подходят StatusCode = 401 ResponseHeaders(HttpWorkerRequest.HeaderWwwAuthenticate) = "Basic realm=""Need username and password""" WriteError(objStream, "Требуется логин и пароль для доступа", VirtualPath) Return True Else Return False End If Else StatusCode = 401 ResponseHeaders(HttpWorkerRequest.HeaderWwwAuthenticate) = "Basic realm=""Use Basic auth""" WriteError(objStream, "Требуется Basic‐авторизация", VirtualPath) Return True End If Else StatusCode = 401 ResponseHeaders(HttpWorkerRequest.HeaderWwwAuthenticate) = "Basic realm=""Authorization""" WriteError(objStream, "Параметры авторизации неверны", VirtualPath) Return True End If End If End Function ''' <summary> ''' Отправляет код статуса 100, чтобы клиент ждал обработку запроса ''' </summary> Public Sub Write100Continue(ByVal objStream As Stream) Dim HeaderBytes = Encoding.ASCII.GetBytes(MakeResponseHeaders(0)) WriteToClient(objStream, HeaderBytes, 0, HeaderBytes.Length) End Sub ''' <summary> ''' Записывает ошибку ответа в поток ''' </summary> ''' <remarks></remarks> Public Sub WriteError(ByVal objStream As Stream, ByVal strMessage As String, ByVal VirtualPath As String) AddCompressionMethodHeader(True) ' Тип документа ResponseHeaders(HttpWorkerRequest.HeaderContentType) = "application/xhtml+xml; charset=utf-8" ' Русский язык для страниц ошибок ResponseHeaders(HttpWorkerRequest.HeaderContentLanguage) = "ru-RU,ru" ' Не поддерживаем соединение при ошибках KeepAlive = False Dim BodyBytes() As Byte = Encoding.UTF8.GetBytes(Messages.FormatErrorMessageBody(StatusCode, VirtualPath, strMessage)) ' Если включено сжатие, нужно записать байты тела в сжатый поток If ZipEnabled = ReadHeadersResult.ZipModes.None Then Dim HeaderBytes = Encoding.ASCII.GetBytes(MakeResponseHeaders(BodyBytes.Length)) WriteToClient(objStream, HeaderBytes, 0, HeaderBytes.Length) End If WriteBody(objStream, BodyBytes, 0, BodyBytes.Length) Flush(objStream) End Sub ''' <summary> ''' Записывает заголовки ответа в поток ''' </summary> ''' <remarks></remarks> Public Sub WriteHeaders(ByVal objStream As Stream, ByVal ContentLength As Long) If ZipEnabled = ReadHeadersResult.ZipModes.None Then Dim bytes() As Byte = Encoding.ASCII.GetBytes(MakeResponseHeaders(ContentLength)) WriteToClient(objStream, bytes, 0, bytes.Length) Erase bytes End If End Sub ''' <summary> ''' Записывает байты тела ответа в поток ''' </summary> ''' <param name="bytes"></param> ''' <param name="offset"></param> ''' <param name="length"></param> ''' <remarks></remarks> Public Sub WriteBody(ByVal objStream As Stream, ByVal bytes() As Byte, ByVal offset As Integer, ByVal length As Integer) If ZipEnabled = ReadHeadersResult.ZipModes.None Then If Not SendOnlyHeaders Then Try objStream.Write(bytes, offset, length) Catch ex As Exception End Try End If Else ZipStream.Write(bytes, offset, length) End If End Sub ''' <summary> ''' Копирует байты тела ответа в клиентский поток ''' </summary> ''' <remarks></remarks> Public Sub CopyBodyStreamToClientStream(ByVal DestinationStream As Stream, ByVal SourceStream As Stream) If ZipEnabled = ReadHeadersResult.ZipModes.None Then Try SourceStream.CopyTo(DestinationStream) Catch ex As Exception End Try Else SourceStream.CopyTo(ZipStream) End If End Sub ''' <summary> ''' Сбрасывает данные в сетевой поток ''' </summary> ''' <remarks></remarks> Public Sub Flush(ByVal objStream As Stream) If ZipEnabled <> ReadHeadersResult.ZipModes.None Then ZipStream.Flush() ZipStream.Close() ZipStream = Nothing ' Отправить заголовки Dim HeaderBytes = Encoding.ASCII.GetBytes(MakeResponseHeaders(MemoryStream.Length)) WriteToClient(objStream, HeaderBytes, 0, HeaderBytes.Length) Erase HeaderBytes If Not SendOnlyHeaders Then ' Отправить тело MemoryStream.Seek(0, SeekOrigin.Begin) Try MemoryStream.CopyTo(objStream) Catch ex As Exception End Try End If MemoryStream.Close() MemoryStream.Dispose() MemoryStream = Nothing End If Try objStream.Flush() Catch ex As Exception End Try End Sub ''' <summary> ''' Создаёт заголовки ответа ''' </summary> ''' <param name="contentLength"></param> ''' <returns></returns> ''' <remarks></remarks> Public Function MakeResponseHeaders(ByVal ContentLength As Long) As String ' Указание кешу, чтобы различал содержимое методу кодирования (gzip, deflate) ResponseHeaders(HttpWorkerRequest.HeaderVary) = "Accept-Encoding" ' Разрешение выполнять частичный GET ResponseHeaders(HttpWorkerRequest.HeaderAcceptRanges) = "bytes" ' Самореклама ResponseHeaders(HttpWorkerRequest.HeaderServer) = "Microsoft-IIS/5.0" ' Текущая дата Dim dNow = DateTime.Now ResponseHeaders(HttpWorkerRequest.HeaderDate) = dNow.ToUniversalTime().ToString("R", DateTimeFormatInfo.InvariantInfo) ' Если не установлен заголовок протухания, то добавить целый месяц If ResponseHeaders(HttpWorkerRequest.HeaderExpires) Is Nothing Then ResponseHeaders(HttpWorkerRequest.HeaderExpires) = dNow.AddMonths(1).ToString("R", DateTimeFormatInfo.InvariantInfo) End If ' Соединение If KeepAlive Then If HttpVersion = ReadHeadersResult.HttpVersions.Http10 Then ' Только при версии протокола 1.0 ResponseHeaders(HttpWorkerRequest.HeaderConnection) = "Keep-Alive" End If Else ResponseHeaders(HttpWorkerRequest.HeaderConnection) = "Close" End If ' Длина содержимого Select Case StatusCode Case 100, 204 ' При кодах 100 и 204 тела нет, поэтому его длина не нужна ResponseHeaders(HttpWorkerRequest.HeaderContentLength) = Nothing Case 304 If ContentLength > 0 Then ResponseHeaders(HttpWorkerRequest.HeaderContentLength) = ContentLength.ToString End If Case Else If ContentLength >= 0 Then ResponseHeaders(HttpWorkerRequest.HeaderContentLength) = ContentLength.ToString End If End Select ' Сборка всех заголовков в одну строку Dim sb As New StringBuilder ' Код состояния sb.AppendLine(String.Join(" ", "HTTP/1.1", StatusCode.ToString, HttpWorkerRequest.GetStatusDescription(StatusCode))) For i = 0 To HttpWorkerRequest.ResponseHeaderMaximum - 1 If ResponseHeaders(i) IsNot Nothing Then sb.AppendLine(HttpWorkerRequest.GetKnownResponseHeaderName(i) & ": " & ResponseHeaders(i)) End If Next ' Дополнительные заголовки Dim sHead = sb.Append(UnknownResponseHeaders.ToString).AppendLine.ToString ' Заголовки запроса и ответа в лог ClientConnection.WriteLog(LockObject, Logs, RequestLine & " " & RemoteIP & vbCrLf & AllRawRequestHeaders & sHead) Return sHead End Function ''' <summary> ''' Разбирает запрос клиента ''' </summary> Public Sub ParseRequestLine(ByVal strVirtualPath As String, ByVal strPhysicalDirectory As String) ' Если есть «?», значит там строка запроса Dim iqs As Integer = Url.IndexOf("?"c) If iqs > 0 Then Path = Url.Substring(0, iqs) QueryString = Url.Substring(iqs + 1) Else Path = Url End If ' Раскодировка пути If Path.IndexOf("%"c) >= 0 Then Path = HttpUtility.UrlDecode(Path) End If ' Получение имени файла по умолчанию If Path.EndsWith("/") Then ' Сначала проверить на xhtml, htm и html ' Если не найдено, то использовать "default.aspx" Dim flag As Boolean For Each DefaultFilename In {"default.xml", "default.xhtml", "default.htm", "default.html"} FilePath = Path & DefaultFilename If IsBadPath(FilePath) Then Exit Sub End If Dim mappedPath = MapPath(strVirtualPath, FilePath, strPhysicalDirectory) If File.Exists(mappedPath) Then flag = True Exit For End If Next If Not flag Then ' файл по умолчанию не найден FilePath = Path & "default.aspx" End If Else FilePath = Path End If PathTranslated = MapPath(strVirtualPath, FilePath, strPhysicalDirectory) End Sub Public Function WriteResponseFromBytes(ByVal objStream As Stream, ByVal bytes() As Byte) As Boolean If ZipEnabled = ReadHeadersResult.ZipModes.None Then Dim HeaderBytes() As Byte = Encoding.ASCII.GetBytes(MakeResponseHeaders(bytes.Length)) WriteToClient(objStream, HeaderBytes, 0, HeaderBytes.Length) ' заголовки в поток Erase HeaderBytes End If WriteBody(objStream, bytes, 0, bytes.Length) Flush(objStream) Return True End Function ''' <summary> ''' Возвращает наличие пути в виртуальном пути ''' </summary> Public Function IsVirtualPathInApp(ByVal strVirtualPath As String, ByVal strPath As String) As Boolean If strPath Is Nothing Then Return False End If If strVirtualPath = "/" AndAlso strPath.StartsWith("/") Then Return True End If strPath = CultureInfo.InvariantCulture.TextInfo.ToLower(strPath) If strPath.StartsWith(LowerCasedVirtualPathWithTrailingSlash) Then Return True End If If strPath = LowerCasedVirtualPath Then Return True End If Return False End Function Public Function IsVirtualPathAppPath(ByVal path As String) As Boolean If path Is Nothing Then Return False End If path = CultureInfo.InvariantCulture.TextInfo.ToLower(path) Return path = LowerCasedVirtualPath OrElse path = LowerCasedVirtualPathWithTrailingSlash End Function Public Function MapPath(ByVal strVirtualPath As String, ByVal path As String, ByVal PhysicalPath As String) As String Dim mappedPath As String = String.Empty If String.IsNullOrEmpty(path) OrElse path.Equals("/") OrElse path.Length = 0 Then mappedPath = PhysicalPath Else If IsVirtualPathAppPath(path) Then mappedPath = PhysicalPath Else If IsVirtualPathInApp(strVirtualPath, path) Then ' Путь внутри приложения mappedPath = PhysicalPath & path.Substring(LowerCasedVirtualPathWithTrailingSlash.Length) Else ' Путь извне If path.StartsWith("/") Then mappedPath = PhysicalPath & path.Substring(1) Else mappedPath = PhysicalPath & path End If End If End If End If mappedPath = mappedPath.Replace("/"c, "\"c) If mappedPath.EndsWith("\") AndAlso Not mappedPath.EndsWith(":\") Then mappedPath = mappedPath.Substring(0, mappedPath.Length - 1) End If Return mappedPath End Function Public Function ProcessReadHeadersHost(ByVal objStream As Stream) As Boolean Const strVirtualPath As String = "/" ' Читать запрос клиента Select Case ReadAllHeaders(objStream) Case ParseRequestLineResult.Success ' Всё правильно, продолжаем работать дальше Case ParseRequestLineResult.HTTPVersionNotSupported ' Версия не поддерживается StatusCode = 505 WriteError(objStream, HTTPVersionNotSupported, strVirtualPath) Return True Case ParseRequestLineResult.MethodNotSupported ' Метод не поддерживается сервером StatusCode = 501 ResponseHeaders(HttpWorkerRequest.HeaderAllow) = ClientConnection.AllSupportHttpMethods WriteError(objStream, String.Format(ClientConnection.MethodNotAllowed, HttpMethod), strVirtualPath) Return True Case ParseRequestLineResult.HostRequired ' Требуется хост StatusCode = 403 WriteError(objStream, ClientConnection.ErrorHost, strVirtualPath) Return True Case ParseRequestLineResult.BadRequest ' Плохой запрос StatusCode = 400 WriteError(objStream, ClientConnection.ErrorBadRequest, strVirtualPath) Return True Case ParseRequestLineResult.EmptyRequest ' Пустой запрос, клиент закрыл соединение Return True End Select ' Проверить заголовок Host, так как он обязателен If WebSites.ContainsKey(RequestHeaders(HttpWorkerRequest.HeaderHost)) Then Return False Else ' Host был неверный StatusCode = 403 ' какой код отправлять при неверном Host? WriteError(objStream, ClientConnection.ErrorHost, strVirtualPath) Return True End If End Function End Structure |
| You are visitor 01402520 — GeezerVison does not store the pages you look up. Best viewed with Netscape Navigator 4.7 or Internet Explorer 6 at 800×600. No cookies required. |