stk/Lib/www-url.stk

;;; www-url.stk - URL Parsing library (used by the www package).
;;;           Version 0.5.
;;;
;;; Copyright (c) 1995 Harvey J. Stein (hjstein@math.huji.ac.il)
;;; This code is freely usable and distributable as long as this
;;; heading remains.

;;; slightly modified by Erick Gallesio (changes are noted with [eg])
;;;      (Last file update: 16-Sep-1999 15:24 (eg)


;;; Usage:
;;; (url:parse-url url)
;;;   Takes a string (url), and returns a parsed url.  One may apply
;;;   The general url form handled is:
;;;
;;;      service://user:password@host:port/path;parameters?query#anchor
;;;
;;;   This function takes a second optional argument - the parent url
;;;   (a parsed url).  When the 2nd argument is given, the url is
;;;   interpreted relative to the parent url.
;;;
;;;   The following functions may be applied to a parsed url:
;;;
;;;   (url:unparse-url url)
;;;         Returns a string (a fully qualified url) which would parse
;;;         into url.
;;;   (url:service  parsed-url)
;;;         Returns the service (i.e. - protocol) (as a symbol), or #f
;;;         if none was given.
;;;   (define url:user parsed-url)
;;;         Returns user name, or #f if none was supplied.
;;;   (url:password parsed-url)
;;;         Returns the password, or #f if none was supplied.
;;;   (url:host parsed-url)
;;;         Returns the host name, or #f if none was supplied.
;;;         Note - the host name can be "" (as in file:///foo/bar).
;;;   (url:port-number parsed-url)
;;;         The port number in the url, or #f if none was supplied.
;;;   (url:filename parsed-url)
;;;         The file name (i.e. - path name) of the url, or #f if
;;;         none was supplied.
;;;   (url:anchor parsed-url)
;;;         The anchor in the url, or #f if none was supplied.  It can
;;;         be "" - as in http://foo.bar.com/file#
;;;   (url:parameters parsed-url)
;;;         The parameters (#f if not supplied, empty string if
;;;         parameter delimiter is supplied, but no parameters are
;;;         supplied.
;;;   (url:query parsed-url)
;;;         The query parameters (#f if not supplied, empty string if
;;;         query delimiter is supplied, but no query parameters are
;;;         supplied.
;;;   (url:through-proxy? parsed-url)
;;;         #t iff url has been parsed to be passed through a proxy.
;;;         Proxying is handled by parsing the proxy address, and
;;;         passing the unparsed url through as the file name.
;;;   (url:pretty-url url . parent)				[eg]
;;;  	    returns a pretty string denoting the URL. url can be parsed or not,
;;;	    parent can be present or not.

;;; Overview:

;;; Internet RFC 1808 discusses how to interpret relative URLs.  In
;;; doing so, it gives algorithms both for parsing URLs and for
;;; computing relative URLs.
;;;
;;; To parse a URL, they say to follow the following procedure:
;;;
;;;   1. Everything incl & after 1st "#" is the anchor, of the rest,
;;;   2. Everything incl & before 1st ":" is the scheme, assuming at
;;;      least 1 char before ":" & all chars are scheme allowable
;;;      [a-zA-Z0-9+.-], of the rest,
;;;   3. If it starts with "//", everything up to (but not incl) next
;;;      ocurrence of "/" or until end is network location.  Of the rest,
;;;   4. everything from 1st "?" until end is the query info.  of the
;;;      rest,
;;;   5. everything from 1st ";" until end is the parameters field.  Of
;;;      the rest,
;;;   6. everything remaining is the path.
;;;
;;; After all this is done, one must remove the "#" from the beginning
;;; of the anchor, the ":" from the end of the scheme, the "//" from
;;; the beginning of the net location, the "?" from the beginning of
;;; the query part, and the ";" from the beginning of the params part.
;;; One typically leaves the "/" on the beginning of the path part,
;;; because it shows up iff the URL is relative.
;;;
;;; This means that the following regexp should be able to separate
;;; out these 6 basic parts of the url:
;;;
;;; "^([a-zA-Z0-9+.-][a-zA-Z0-9+.-]+:|)(//[^#/]*|)([^#?;]*|)(;[^?#]*|)(\\?[^#]*|)(#.*|)$"
;;;
;;; Once this is done, the net address must be parsed.  I believe this
;;; can be done as follows:
;;;
;;;   1. Everything before & including the 1st "@" is the
;;;      username/password part.  Of the rest,
;;;   2. Everything after & including the last ":" is the port number,
;;;      provided the ":" is only followed by digits
;;;   3. What's left is the host name.
;;;
;;; Bugs
;;;   -The parsing of http://foo.bar.com is problematic.  On the one
;;;    hand, there's no file name 
;;;    become /.			[eg] corrected
;;;   -Proxy junk barely tested...


(require "fs")

(define-module URL
   (export url:parse-url url:unparse-url url:service url:user       
           url:password url:host url:port-number url:filename   
           url:anchor url:parameters url:query url:through-proxy?
           url:pretty-url))

(select-module URL)

(define url:*proxy-env-vars*
  '((http   "HTTP_PROXY")
    (ftp    "FTP_PROXY")
    (wais   "WAIS_PROXY")
    (gopher "GOPHER_PROXY")))

(define *proxy-servers* ())
;;; Takes a URL as an argument and returns a list containing the 
;;; protocol, the host name, and the file name.

(define (parse-url url . parent)
  (proxitize (apply relativize (basic-parse-url url)
		    (cond 
		       ((null? parent) '())
		       ((through-proxy? (car parent))
		          (list (basic-parse-url (apply unparse-url parent))))
		       (else parent)))))

(define (basic-parse-url url)
  (let* ((base (split url-regexp url))
	 (up-hp (split up-hp-regexp (safe-list-ref base 1)))
	 (u-p   (split u-p-regexp (safe-list-ref up-hp 0)))
	 (h-p   (split-hp-part (safe-list-ref up-hp 1))))
;;    (format #t "basic-parse-url:\n   base=~s\n   up-hp=~s\n   u-p=~s\n   h-p=~s\n"
;;	    base up-hp u-p h-p)
    (if (not (and base up-hp u-p h-p))
	#f
      (let* ((dirty-url (map (lambda (x) (if (string=? x "") #f x))
			     (append (list (car base))
				     u-p
				     h-p
				     (cddr base))))
	     (srv  (maybe-chop-end (list-ref dirty-url 0)))
	     (user (maybe-chop-end (list-ref dirty-url 1)))
	     (pass (maybe-chop-end (list-ref dirty-url 2)))
	     (host (list-ref dirty-url 3))
	     (port (maybe-chop-beg (list-ref dirty-url 4)))
	     (path (list-ref dirty-url 5))
	     (parm (maybe-chop-beg (list-ref dirty-url 6)))
	     (quer (maybe-chop-beg (list-ref dirty-url 7)))
	     (anch (maybe-chop-beg (list-ref dirty-url 8))))
	(if (and (not host)
		 (string? (safe-list-ref base 1))
		 (> (string-length (safe-list-ref base 1)) 0))
	    (set! host ""))
	(list (if srv (string->symbol (string-lower srv))
		#f)
	      user
	      pass
	      host
	      (if port (string->number port)
		#f)
	      (or path "/")
	      parm
	      quer
	      anch
	      #f)))))

(define (relativize url . parent)
  (define (inherit-service)
    (set! url (smerge-lists url parent 0)))

  (define (inherit-netloc)
    (set! url (smerge-lists url parent 1 2 3 4)))

  (define (inherit-path)
    (set! url (smerge-lists url parent 5)))

  (define (inherit-parameters)
    (set! url (smerge-lists url parent 6)))

  (define (inherit-query)
    (set! url (smerge-lists url parent 7)))

  (define (smerge-lists url parent . positions)
    (define (smerge-aux url parent positions ref)
      (cond ((null? positions) url)
	    ((null? url) parent)
	    ((null? parent) url)
	    ((= (car positions) ref)
	     (cons (car parent)
		   (smerge-aux (cdr url) (cdr parent) (cdr positions) (+ 1 ref))))
	    (else
	     (cons (car url)
		   (smerge-aux (cdr url) (cdr parent) positions (+ 1 ref))))))
    (smerge-aux url parent positions 0))

;  (define (dirname f)			;; [eg] deleted to use fs.stk instead
;    (define r (string->regexp "^(.*/|)([^/]*)$"))
;    (car (split r f)))

  (define (merge-paths)
    (let* ((base (string-append (dirname (filename parent))
				(if (eq? (os-kind) 'Unix) "/" "\\")     ; [eg]
				(filename url)))
	   (slb  (string-length base))
	   (newpath 
	    (cond ((and (> slb 0)
			 (char=? (string-ref base (- slb 1)) #\/))
		   (string-append (expand-file-name base) "/"))
		  ((and (= slb 1)
			(char=? (string-ref base 0) #\.))
		   (string-append (expand-file-name base) "/"))
		  ((and (= slb 2)
			(or (string=? base "..")
			    (string=? base "/.")))
		   (string-append (expand-file-name base) "/"))
		  ((and (> slb 2)
			(char=? (string-ref base (- slb 2)) #\/)
			(char=? (string-ref base (- slb 1)) #\.))
		   (string-append (expand-file-name base) "/"))
		  ((and (> slb 2)
			(char=? (string-ref base (- slb 3)) #\/)
			(char=? (string-ref base (- slb 2)) #\.)
			(char=? (string-ref base (- slb 1)) #\.))
		   (string-append (expand-file-name base) "/"))
		  (else
		   (expand-file-name base)))))
      (set! slb (string-length newpath))
      (if (and (> slb 1)
	       (char=? (string-ref newpath (- slb 1)) #\/)
	       (char=? (string-ref newpath (- slb 2)) #\/))
	  (set! newpath (substring newpath 0 (- slb 1))))
;;      (format #t "merge-paths: base=~s, newpath=~s\n" base newpath)
      (set! url (smerge-lists url `(serv user pass host port ,newpath) 5))))
      
  (if (not (null? parent)) (set! parent (car parent)))
  (cond ((null? parent) url)
	((string=? "" (unparse-url parent)) url)
	((string=? "" (unparse-url url)) parent)
	((service url) url)
	((host url) (inherit-service) url)
	((and (filename url)
	      (> (string-length (filename url)) 0)
	      (char=? (string-ref (filename url) 0) #\/))
	 (inherit-service) (inherit-netloc) url)
	((and (not (filename url))
	      (parameters url))
	 (inherit-service) (inherit-netloc) (inherit-path) url)
	((and (not (filename url))
	      (query url))
	 (inherit-service) (inherit-netloc) (inherit-path) (inherit-parameters)
	 url)
	((not (filename url))
	 (inherit-service) (inherit-netloc) (inherit-path) (inherit-parameters)
	 (inherit-query)
	 url)
	(else
	 (inherit-service) (inherit-netloc) (merge-paths) url)))

(define (proxitize parsed-url)
  (let ((proxy (assoc (service parsed-url) *proxy-servers*)))
    (cond (proxy
	   (set! proxy (cadr proxy))
	   (list (service proxy)
		 (user proxy)
		 (password proxy)
		 (host proxy)
		 (port-number proxy)
		 (unparse-url parsed-url)
		 (parameters proxy)
		 (query proxy)
		 (anchor proxy)
		 #t))			; Is through proxy.
	  (else
	   parsed-url))))
	
(define (unparse-url url)
  (cond ((through-proxy? url)
	 (filename url))
	(else
	 (let ((srv (service url)))
	   ; (if srv (set! srv (symbol->string srv))) [eg]
	   (set! srv  (if srv (symbol->string srv) "file"))
	   (string-append (maybe-append srv ":")
			  (string-netaddr url)
			  (if (filename url) (filename url) "")
			  (maybe-append ";" (parameters url))
			  (maybe-append "?" (query url))
			  (maybe-append "#" (anchor url)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (pretty-url url . parent)    ;; [eg] added for pretty mesages
  (unless (string? url)
    (set! url (url:unparse-url url)))
  (url:unparse-url (apply url:parse-url url parent)))


;;;  --------- Regexps for parsing ---------------

(define url-regexp 
  (string->regexp
   "^([[a-zA-Z0-9+.-][a-zA-Z0-9+.-]+:|)(//[^#/]*|)([^#?;]*|)(;[^?#]*|)(\\?[^#]*|)(#.*|)$"))

(define up-hp-regexp
  (string->regexp
   "^/?/?([^@]*@|)(.*)$"))		; Strips off // automatically.

(define u-p-regexp
  (string->regexp
   "^([^@:]*[:@]|)(.*)$"))

(define h-p-test-regexp
  (string->regexp
   "^(.*)(:[0-9]+)$"))

;;; ----------------- Support routines for basic-parse-url ---------------
(define (string-netaddr url)
  (let ((prt (port-number url)))
    (if prt (set! prt (number->string prt)))
    (cond ((password url)
	   (string-append "//" (user url) ":" (password url)
			  "@" (host url)
			  (maybe-append ":" prt)))
	   ((user url)
	    (string-append "//" (user url) "@" (host url)
			   (maybe-append ":" prt)))
	   ((host url)
	    (string-append "//" (host url)
			   (maybe-append ":" prt)))
	   (else ""))))

(define (split-hp-part h-p)
  (or (split h-p-test-regexp h-p)
      (list h-p "")))

(define (maybe-append s1 s2)
  (if (and s1 s2) (string-append s1 s2)
    ""))

(define (split regexp maybe-str)
  (if (string? maybe-str)
      (apply-matches (regexp maybe-str) maybe-str)
    #f))

(define (safe-list-ref maybe-list index)
  (if (and (list? maybe-list)
	   (< index (length maybe-list)))
      (list-ref maybe-list index)
    #f))

(define (maybe-chop-end maybe-string)
  (if (and (string? maybe-string)
	   (> (string-length maybe-string) 0))
      (substring maybe-string 0 (- (string-length maybe-string) 1))
    #f))

(define (maybe-chop-beg maybe-string)
  (if (and (string? maybe-string)
	   (> (string-length maybe-string) 0))
      (substring maybe-string 1 (string-length maybe-string))
    #f))


(define (apply-matches matches string)
  (if matches
      (map (lambda (m) (apply substring string m))
	   (cdr matches))
    #f))

;;; ---------- Url access routines -------------

(define (service url)
  (list-ref url 0))

(define (user url)
  (list-ref url 1))

(define (password url)
  (list-ref url 2))

(define (host url)
  (list-ref url 3))

(define (port-number url)
  (list-ref url 4))

(define (filename url)
  (list-ref url 5))

(define (parameters url)
  (list-ref url 6))

(define (query url)
  (list-ref url 7))

(define (anchor url)
  (list-ref url 8))

(define (through-proxy? url)
  (list-ref url 9))

;;; ------------ Exports -------------------------
(define url:parse-url      parse-url)
(define url:unparse-url    unparse-url)
;(define url:service       service)	[eg] to default to file if nothing else
(define url:service        (lambda (url) (or (service url) 'file)))
(define url:user           user)
(define url:password       password)
(define url:host           host)
(define url:port-number    port-number)
(define url:filename       filename)
(define url:anchor         anchor)
(define url:through-proxy? through-proxy?)
(define url:pretty-url     pretty-url)

;;; -------------- Set up proxy list -----------------
(define (get-proxy-evar evar)
  (let ((e (getenv evar)))
    (if e
	(basic-parse-url e)
      #f)))


(define *proxy-servers*
  (let loop ((l url:*proxy-env-vars*))
       (cond ((null? l) ())
	     (else
	      (let ((p (get-proxy-evar (cadar l))))
		(if p
		    (cons (list (caar l) p)
			  (loop (cdr l)))
		  (loop (cdr l))))))))


(provide "www-url")