Option Explicit

Const NEWGET = "GET <path> HTTP/1.1\n" & _
               "Host: <host>\n" & _
               "Accept: */*\n\n"

Private mstrLastAddress As String
Private mstrLastLocation As String
Private mstrLastURL As String
Private mstrCurrentURL As String
Private mbTextRead As Boolean
Private mstrCurrentText As String
Private mlngCurrentSize As Long
Private mlngCurrentBytes As Long
Private mlngStopPosition As Long
Private mstrLocalFile As String
Private mstrTmpExt As String
Private mintResumePosition As Long

Event Error(Message As String)
Event TextReadComplete(Text As String)
Event DownloadComplete()
Event Progress(CurrentBytes As Long, TotalBytes As Long, KBPS As Long)

Private Sub Download(URL As String, Optional StopPosition As Long = 0)

    mstrLastURL = ""
    mstrLastLocation = ""
    mstrCurrentText = ""
    mlngCurrentBytes = 0
    mlngCurrentSize = 0
    mlngStopPosition = StopPosition
    
    mstrCurrentURL = URL
    Winsock1.Close
    Winsock1.Connect CrackURL(URL)(0), 80
    
End Sub

Private Sub Winsock1_Connect()

    Dim strRequest As String
    
    debugprint "Connected to " & Winsock1.RemoteHostIP
    
    If mstrLastAddress = "" Then
       strRequest = FormatHeader(NEWGET, mstrCurrentURL)
    Else
       strRequest = FormatHeader(NEWGET, mstrLastURL)
    End If
    
    debugprint "-------------SEND----------------------"
    debugprint strRequest
    
    Winsock1.SendData strRequest

End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

Dim intI As Integer
Dim intJ As Integer
Dim Data() As Byte
Dim strData As String
Dim strDataLn() As String
Dim strSplit() As String
Dim strSplit2() As String
Dim strFilePath As String

Winsock1.GetData Data, vbByte Or vbArray
mlngCurrentBytes = mlngCurrentBytes + bytesTotal

strData = StrConv(Data, vbUnicode)
'MsgBox strData

Form1.Caption = mlngCurrentBytes & "/" & mlngCurrentSize & " [" & mlngStopPosition & "]"


' stop on zero (only in text mode)

If mbTextRead = True And mlngCurrentSize = 0 And Right(strData, 7) = vbCrLf & "0" & vbCrLf & vbCrLf Then
    RaiseEvent TextReadComplete(mstrCurrentText)
    
    Winsock1.Close
    Exit Sub
End If


' stop on size

If mbTextRead = False And (mlngCurrentSize > 0 And mlngCurrentBytes >= mlngCurrentSize) Or _
   mbTextRead = True And mlngCurrentBytes >= mlngStopPosition Then
    
    If mbTextRead Then
        RaiseEvent TextReadComplete(mstrCurrentText)
    Else
        Put #1, LOF(1) + 1, Data
        Close #1
        RaiseEvent DownloadComplete
    End If
    
    Winsock1.Close
    Exit Sub
End If


' if it hasnt stopped, check for http headers

If cmp(strData, "HTTP/1.1 ") Then

strDataLn = Split(strData, vbCrLf)

Do While Not cmp(strDataLn(intI), "Content-Length: ") And intI < UBound(strDataLn)
    intI = intI + 1
Loop

mlngCurrentSize = Val(Trim(Replace(strDataLn(intI), "Content-Length: ", "")))

Select Case strDataLn(0)

Case "HTTP/1.1 200 OK" ' if all ok ?
    MsgBox "starting transfer"
    If mbTextRead Then
        strData = Split(strData, vbCrLf & vbCrLf, 2)(1)
        mstrCurrentText = mstrCurrentText & strData
    Else
        strFilePath = mstrLocalFile & mstrTmpExt
    
        'Do While FileExists(strFilePath)
        '    intJ = intJ + 1
        '    strFilePath = mstrLocalFile & "(" & intJ & ")" & mstrTmpExt
        'Loop
        
        Open strFilePath For Binary Access Write As #1
    End If

Case "HTTP/1.1 404", "HTTP/1.1 410" ' if missing file ?
    RaiseEvent Error("Invalid URL or missing file")
    Winsock1.Close
    
Case "HTTP/1.1 206" ' if resumed ok ?
    strData = Split(strData, vbCrLf & vbCrLf, 2)(1)
    mstrCurrentText = mstrCurrentText & strData
    
Case "HTTP/1.1 303", "HTTP/1.1 302" ' if redirection ?
    debugprint "-------------RECV----------------------"
    strSplit = Split(strData, vbCrLf)
    
    For intI = 0 To UBound(strSplit)
        debugprint strSplit(intI)
        If Left$(strSplit(intI), 9) = "Location:" Then
            mstrLastAddress = strSplit(intI)
            strSplit2 = Split(mstrLastAddress, "/")
            mstrLastAddress = strSplit2(2)

            mstrLastLocation = strSplit2(3)
            mstrLastURL = Trim(Replace(strSplit(intI), "Location:", ""))
        End If
    Next

    Winsock1.Close
    Winsock1.Connect mstrLastAddress, 80 ' connect to new address
    Exit Sub

End Select
Else ' if we dont have http header (raw data) ?

    If mbTextRead Then
        mstrCurrentText = mstrCurrentText & strData
    Else
        Put #1, LOF(1) + 1, Data
    End If

End If
End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
    
    RaiseEvent Error(Description)
    
End Sub

Public Sub StartDownload(URL As String, LocalPath As String, Optional TempExtension As String = "")
    Dim tmpPath As String
    
    mstrLocalFile = LocalPath
    mstrTmpExt = TempExtension
    
    tmpPath = mstrLocalFile & mstrTmpExt
    
    If FileExists(tmpPath) Then
        mintResumePosition = FileLen(tmpPath)
    End If
    
    mbTextRead = False
    Download URL
    
End Sub

Public Sub ReadUrl(URL As String, Optional StopPosition As Long = 0)

    mbTextRead = True
    Download URL, StopPosition
    
End Sub

Private Function cmp(ByVal s1 As String, ByVal s2 As String) As Boolean

    If LCase(Left(s1, Len(s2))) = LCase(s2) Then
    cmp = True
    Else
    cmp = False
    End If
    
End Function


Private Function CrackURL(URL As String) As String()

    On Error Resume Next
    
    URL = Trim(Replace(URL, "http://", ""))
    CrackURL = Split(URL, "/", 2)
    
End Function

Private Function FormatHeader(strHeader As String, URL As String) As String

    On Error Resume Next
    
    Dim tmpHeader As String
    Dim strSplit() As String
    
    strSplit = CrackURL(URL)
    
    tmpHeader = Replace(strHeader, "\n", vbCrLf)
    tmpHeader = Replace(tmpHeader, "<host>", strSplit(0))
    tmpHeader = Replace(tmpHeader, "<path>", "/" & strSplit(1))
    FormatHeader = tmpHeader

End Function


Private Function FileExists(fname) As Boolean

    On Error Resume Next
    
    If fname = "" Or Right(fname, 1) = "\" Then
        FileExists = False
        Exit Function
    End If
    
    FileExists = (Dir(fname) <> "")
    
End Function

Private Sub debugprint(a)
    'If Len(Form1.Text1.Text) > 65000 Then Form1.Text1.Text = ""
    Form1.Text1.Text = Form1.Text1.Text & vbCrLf & a
End Sub