Mercurial > hg > egg-tcls

changeset 327:a5282cdc56e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
urllog: Fix redirection handling for HTTP 1.1.
author Matti Hamalainen <ccr@tnsp.org>
date Wed, 03 Jun 2015 18:51:30 +0300
parents 2a85f7dd9733
children b3fded816ad8
files urllog.tcl
diffstat 1 files changed, 30 insertions(+), 16 deletions(-) [+]
line wrap: on
line diff
--- a/urllog.tcl	Wed Jun 03 18:51:06 2015 +0300
+++ b/urllog.tcl	Wed Jun 03 18:51:30 2015 +0300
@@ -282,11 +282,12 @@
 }
 
 #-------------------------------------------------------------------------
-proc urllog_validate_url { urlNick urlChan urlMStr urlMProto } {
+proc urllog_validate_url { urlNick urlChan urlMStr urlMProto urlMHostName } {
   global urllog_tld_list urlmsg_nosuchhost urllog_httprep urlmsg_unknown_tld
   global urllog_shorturl_prefix urllog_shorturl urllog_check_tld
   upvar 1 $urlMStr urlStr
   upvar 1 $urlMProto urlProto
+  upvar 1 $urlMHostName urlHostName
 
   ### Try to guess the URL protocol component (if it is missing)
   set u_checktld 1
@@ -297,7 +298,7 @@
   }
 
   ### Handle URLs that have an IPv4-address
-  if {[regexp "(\[a-z\]+)://(\[0-9\]{1,3})\\.(\[0-9\]{1,3})\\.(\[0-9\]{1,3})\\.(\[0-9\]{1,3})" $urlStr u_match urlProto ni1 ni2 ni3 ni4]} {
+  if {[regexp "(\[a-z\]+)://(\[0-9\]{1,3})\\.(\[0-9\]{1,3})\\.(\[0-9\]{1,3})\\.(\[0-9\]{1,3})" $urlStr urlMatch urlProto ni1 ni2 ni3 ni4]} {
     # Check if the IP is on local network
     if {$ni1 == 127 || $ni1 == 10 || ($ni1 == 192 && $ni2 == 168) || $ni1 == 0} {
       urllog_log "URL pointing to local or invalid network, ignored ($urlStr)."
@@ -321,15 +322,15 @@
 
   ### Get URL protocol component
   set urlProto ""
-  regexp "(\[a-z\]+)://" $urlStr u_match urlProto
+  regexp "(\[a-z\]+)://" $urlStr urlMatch urlProto
 
   ### Check the PORT (if the ":" is there)
-  set u_record [split $urlStr "/"]
-  set u_hostname [lindex $u_record 2]
-  set u_port [lindex [split $u_hostname ":"] end]
+  set urlRecord [split $urlStr "/"]
+  set urlHostName [lindex $urlRecord 2]
+  set urlPort [lindex [split $urlHostName ":"] end]
 
-  if {![urllog_isnumber $u_port] && $u_port != "" && $u_port != $u_hostname} {
-    urllog_log "Broken URL from $urlNick: ($urlStr) illegal port $u_port"
+  if {![urllog_isnumber $urlPort] && $urlPort != "" && $urlPort != $urlHostName} {
+    urllog_log "Broken URL from $urlNick: ($urlStr) illegal port $urlPort"
     return 0
   }
 
@@ -341,7 +342,7 @@
 
   ### Check the Top Level Domain (TLD) validity
   if {$urllog_check_tld != 0 && $u_checktld != 0} {
-    set u_sane [lindex [split $u_hostname "."] end]
+    set u_sane [lindex [split $urlHostName "."] end]
     set u_tld [lindex [split $u_sane ":"] 0]
     set u_found 0
 
@@ -380,22 +381,23 @@
   }
   
   ### Validate URL compoments, etc.
-  set u_proto ""
-  if {![urllog_validate_url $urlNick $urlChan urlStr u_proto]} {
+  set urlProto ""
+  set urlHostName ""
+  if {![urllog_validate_url $urlNick $urlChan urlStr urlProto urlHostName]} {
     return 1
   }
 
   ### Do we perform additional checks?
-  if {$urllog_extra_checks == 0 || !(($http_tls_support != 0 && $u_proto == "https") || $u_proto == "http")} {
+  if {$urllog_extra_checks == 0 || !(($http_tls_support != 0 && $urlProto == "https") || $urlProto == "http")} {
     # No optional checks, or it's not http/https.
     if {$urllog_extra_strict == 0} {
       # Strict checking disabled, so add the URL, if it does not exist already.
       urllog_addurl $urlStr $urlNick $urlHost $urlChan ""
       return 1
-    } elseif {$http_tls_support == 0 && $u_proto == "https"} {
+    } elseif {$http_tls_support == 0 && $urlProto == "https"} {
       # Strict ENABLED: If TLS support is disabled and we have https, do nothing
       return 1
-    } elseif {$u_proto != "http" && $u_prot != "https"} {
+    } elseif {$urlProto != "http" && $urlProto != "https"} {
       # Strict ENABLED: It's not http, or https
       return 1
     }
@@ -409,10 +411,16 @@
   ### Handle redirects
   if {$ucode >= 301 && $ucode <= 302} {
     set nurlStr $umeta(Location)
+    if {![regexp "\[a-z\]+://" $nurlStr]} {
+      if {[string range $nurlStr 0 0] != "/"} {
+        append nurlStr "/"
+      }
+      set nurlStr "${urlProto}://${urlHostName}${nurlStr}"
+    }
     urllog_log "Redirection: $urlStr -> $nurlStr"
     set urlStr $nurlStr
 
-    if {![urllog_validate_url $urlNick $urlChan urlStr urlProto]} {
+    if {![urllog_validate_url $urlNick $urlChan urlStr urlProto urlHostName]} {
       return 1
     }
 
@@ -424,10 +432,16 @@
   ### Handle 2nd level redirects
   if {$ucode >= 301 && $ucode <= 302} {
     set nurlStr $umeta(Location)
+    if {![regexp "\[a-z\]+://" $nurlStr]} {
+      if {[string range $nurlStr 0 0] != "/"} {
+        append nurlStr "/"
+      }
+      set nurlStr "${urlProto}://${urlHostName}${nurlStr}"
+    }
     urllog_log "Redirection #2: $urlStr -> $nurlStr"
     set urlStr $nurlStr
 
-    if {![urllog_validate_url $urlNick $urlChan urlStr urlProto]} {
+    if {![urllog_validate_url $urlNick $urlChan urlStr urlProto urlHostName]} {
       return 1
     }