Commit 42912a46 authored by asmyles's avatar asmyles

initial check-in

(defpackage #:com.smyles.uri
(:nicknames #:uri)
(:use #:common-lisp)
(:export #:uri #:uri-scheme #:uri-heir-part #:uri-query #:uri-fragment #:resolve #:relativize #:heirarchical? #:relative?)
(:export #:register-scheme #:define-scheme)
;standard schemes
(:export #:acap #:cid #:crid #:data #:dav #:dict #:dns #:fax #:file #:ftp #:go #:gopher #:h323 #:http #:https #:im #:imap #:info #:ipp #:iris.beep #:ldap #:mailto #:mid #:modem #:mtqp #:mupdate #:news #:nfs #:nntp #:opaquelocktoken #:pop #:pres #:rtsp #:service #:sip #:sips #:snmp #:soap.beep #:soap.beeps #:tag #:tel #:telnet #:tftp #:thismessage #:tip #:urn #:vemmi #:xmlrpc.beep #:xmlrpc.beeps #:xmpp #:z39.50r #:z39.50s)
;from util.lisp
(:export #:gentag #:tag-uri #:tag-name)
;others from uri.lisp
(:export #:authority #:path #:user-info #:port #:host)
(:export #:set-uri-reader-syntax))
(in-package #:com.smyles.uri)
(defvar *scheme-registry* (make-hash-table :test #'equal))
(defmacro define-scheme (name (&rest slots) &optional documentation)
(defstruct (,name (:include uri (scheme ',name))
(:constructor ,name (heir-part &key query fragment)))
,@(when documentation (list documentation)))
,@(loop for (method (uri . args) . body) in slots
collect `(defmethod ,method ((,uri ,name) ,@args) ,@body) )))
;primarily used by people who make their own schemes
(defun register-scheme (name sym)
(setf (gethash (string-downcase name) *scheme-registry*) sym))
(defun scheme (name)
(flet ((read-case (str)
(ecase (readtable-case *readtable*)
(:upcase (string-upcase str))
(:downcase (string-downcase str))
(:preserve str)
(:invert str))))
(and name (or (find-symbol (read-case name) :com.smyles.uri) (gethash (string-downcase name) *scheme-registry*) (intern (read-case name) :keyword)))))
(define-scheme acap () "application configuration access protocol [RFC2244]")
(define-scheme cid
((authority (uri)
(let* ((heir-part (uri-heir-part uri))
(start-auth (search "@" heir-part)))
(when start-auth
(subseq heir-part (1+ start-auth)))))
(user-info (uri)
(let* ((heir-part (uri-heir-part uri))
(start-auth (search "@" heir-part)))
(when start-auth
(subseq heir-part 0 start-auth)))))
"content identifier [RFC2392]")
(define-scheme crid () "TV-Anytime Content Reference Identifier [RFC4078]")
(define-scheme data () "data [RFC2397]")
(define-scheme dav () "dav [RFC2518]")
(define-scheme dict () "dictionary service protocol [RFC2229]")
(define-scheme dns () "Domain Name System [RFC4501]")
(define-scheme fax () "fax [RFC3966]")
(define-scheme file () "Host-specific file names [RFC1738]")
(define-scheme ftp () "File Transfer Protocol [RFC1738]")
(define-scheme go () "go [RFC3368]")
(define-scheme gopher () "The Gopher Protocol [RFC4266]")
(define-scheme h323 () "H.323 [RFC3508]")
(define-scheme http () "Hypertext Transfer Protocol [RFC2616]")
(define-scheme https () "Hypertext Transfer Protocol Secure [RFC2818]")
(define-scheme im () "Instant Messaging [RFC3860]")
(define-scheme imap () "internet message access protocol [RFC2192]")
(define-scheme info () "Information Assets with Identifiers in Public Namespaces [RFC4452]")
(define-scheme ipp () "Internet Printing Protocol [RFC3510]")
(define-scheme iris.beep () "iris.beep [RFC3983]")
(define-scheme ldap () "Lightweight Directory Access Protocol [RFC4516]")
(define-scheme mailto () "Electronic mail address [RFC2368]")
(define-scheme mid () "message identifier [RFC2392]")
(define-scheme modem () "modem [RFC3966]")
(define-scheme mtqp () "Message Tracking Query Protocol [RFC3887]")
(define-scheme mupdate () "Mailbox Update (MUPDATE) Protocol [RFC3656]")
(define-scheme news () "USENET news [RFC1738]")
(define-scheme nfs () "network file system protocol [RFC2224]")
(define-scheme nntp () "USENET news using NNTP access [RFC1738]")
(define-scheme opaquelocktoken () "opaquelocktokent [RFC2518]")
(define-scheme pop () "Post Office Protocol v3 [RFC2384]")
(define-scheme pres () "Presence [RFC3859]")
(define-scheme rtsp () "real time streaming protocol [RFC2326]")
(define-scheme service () "service location [RFC2609]")
(define-scheme sip () "session initiation protocol [RFC3261]")
(define-scheme sips () "secure session initiation protocol [RFC3261]")
(define-scheme snmp () "Simple Network Management Protocol [RFC4088]")
(define-scheme soap.beep () "soap.beep [RFC3288]")
(define-scheme soap.beeps () "soap.beeps [RFC3288]")
(define-scheme tag () "tag [RFC4151]")
(define-scheme tel () "telephone [RFC3966]")
(define-scheme telnet () "Reference to interactive sessions [RFC4248]")
(define-scheme tftp () "Trivial File Transfer Protocol [RFC3617]")
(define-scheme thismessage () "multipart/related relative reference resolution [RFC2557]")
(define-scheme tip () "Transaction Internet Protocol [RFC2371]")
(define-scheme urn () "Uniform Resource Names (click for registry) [RFC2141]")
(define-scheme vemmi () "versatile multimedia interface [RFC2122]")
(define-scheme xmlrpc.beep () "xmlrpc.beep [RFC3529]")
(define-scheme xmlrpc.beeps () "xmlrpc.beeps [RFC3529]")
(define-scheme xmpp () "Extensible Messaging and Presence Protocol [RFC4622]")
(define-scheme z39.50r () "Z39.50 Retrieval [RFC2056]")
(define-scheme z39.50s () "Z39.50 Session [RFC2056])")
(in-package #:com.smyles.uri)
(defun set-uri-reader-syntax (uri-dmc &optional (readtable *readtable*))
(flet ((uri-syntax (stream char prefix)
(declare (ignore c p))
(uri (read stream t nil t))))
(set-dispatch-macro-character (char uri-dmc 0) (char uri-dmc 1) readtable)))
(defsystem #:uri
:author "Arthur Smyles"
:version "0.2"
:components((:file "package")
(:file "uri" :depends-on ("package"))
(:file "schemes" :depends-on ("uri"))
(:file "syntax" :depends-on ("uri"))
(:file "util" :depends-on ("uri"))
(in-package #:com.smyles.uri)
;uri's are special symbols that define a scheme and scheme specific part.
;they cannot be directly called because the scheme defines the type of uri.
;see RFC #### for details
(defstruct uri
"Base class for all uri's"
(scheme nil :type symbol :read-only t)
(heir-part nil :type string :read-only t)
(query nil :type (or null string) :read-only t)
(fragment nil :type (or null string) :read-only t))
(defgeneric authority (uri))
(defgeneric path (uri))
(defgeneric user-info (uri))
(defgeneric host (uri))
(defgeneric port (uri))
(defmethod print-object ((obj uri) stream)
((and *print-escape* *read-eval*) (format stream "#.(~S \"~@[~(~A~):~]~A~@[?~A~]~@[#~A~]\")" 'uri (uri-scheme obj) (uri-heir-part obj) (uri-query obj) (uri-fragment obj)))
(*print-escape* (format stream "(~S \"~@[~(~A~):~]~A~@[?~A~]~@[#~A~]\")" 'uri (uri-scheme obj) (uri-heir-part obj) (uri-query obj) (uri-fragment obj)))
(t (format stream "~@[~(~A~):~]~A~@[?~A~]~@[#~A~]" (uri-scheme obj) (uri-heir-part obj) (uri-query obj) (uri-fragment obj)))))
(defun uri (uri &aux (scheme? (and (position #\: uri) (subseq uri 0 (position #\: uri)))))
"parses a uri into an object. If the scheme is registered then the returned object is of that type. otherwise it is a uri structure. Also supports relative uri."
(let ((scheme (scheme scheme?))
(scheme-body (if scheme?
(subseq uri (1+ (length scheme?)))
(let ((heir-part (subseq scheme-body 0 (or (position #\? scheme-body) (position #\# scheme-body))))
(query (and (position #\? scheme-body) (subseq scheme-body (1+ (position #\? scheme-body)) (position #\# scheme-body))))
(fragment (and (position #\# scheme-body) (subseq scheme-body (1+ (position #\# scheme-body))))))
(if (or (null scheme) (keywordp scheme)) ;scheme is not registered or relative uri.
(make-uri :scheme scheme :heir-part heir-part :query query :fragment fragment)
(funcall scheme heir-part :query query :fragment fragment)
(defmethod authority ((uri string))
"returns the authority component of the uri if it is heirarchical. Otherwise nil"
(authority (uri uri)))
(defmethod authority ((uri uri))
"returns the authority component of the uri if it is heirarchical. Otherwise nil"
(let* ((heir-part (uri-heir-part uri))
(start-auth (search "//" heir-part))) ;;only if it starts with authority-part do we check otherwise return nil
(when start-auth
(subseq heir-part 2 (position #\/ heir-part :start 2)))))
(defmethod path ((uri uri))
"returns the path component if the uri is heirarchical"
(let* ((heir-part (uri-heir-part uri))
(start-auth (search "//" heir-part))
(if start-auth (position #\/ heir-part :start (+ 2 start-auth)) 0)))
(subseq heir-part start-path)))
(defmethod path ((uri string))
"returns the path component if the uri is heirarchical"
(path (uri uri)))
(defmethod user-info ((uri uri))
"returns the user-info portion of a uri if it is heirarchical"
(let* ((authority (authority uri)) (end-userinfo (position #\@ authority)))
(if end-userinfo (subseq authority 0 end-userinfo))))
(defmethod port ((uri uri))
"returns the port number in the authority component"
(let* ((authority (authority uri))
(start-port (position #\: authority :from-end t)))
(if start-port (parse-integer (subseq authority (1+ start-port)) :junk-allowed t))))
(defmethod host ((uri uri))
"returns the host"
(let ((authority (authority uri)))
(subseq authority
(if (user-info uri)
(1+ (position #\@ authority)) 0)
(if (port uri) (position #\: authority :from-end t)))))
(defun relative? (uri)
"Is this a relative uri"
(not (uri-scheme uri)))
(defun heirarchical? (uri)
"Is this a heierarchical uri"
(char= (char (uri-heir-part uri) 0) #\/))
(defun relativize (base uri)
(unless base (return-from relativize uri))
(let* ((base-heir-part (subseq (uri-heir-part base) 0 (1+ (position #\/ (uri-heir-part base) :from-end t))))
(base? (search base-heir-part (uri-heir-part uri))))
(if (and (heirarchical? base) (heirarchical? uri)
(eq (uri-scheme base) (uri-scheme uri))
(make-uri :scheme nil
:heir-part (subseq (uri-heir-part uri) (+ base? (length base-heir-part)))
:query (uri-query uri)
:fragment (uri-fragment uri))
;TODO fix this with new api
(defun resolve (base-uri uri)
(labels ((merge-heir-parts (base-uri uri)
(let ((uri-authority (authority uri))
(uri-path (path uri)))
(if uri-authority (uri-heir-part uri)
(let ((base-authority (authority base-uri))
(base-path (path base-uri)))
(if (char= (char uri-path 0) #\/)
(format nil "//~A~A" base-authority (remove-dot-segments uri-path))
(format nil "//~A~A" base-authority (remove-dot-segments (merge-paths base-path uri-path))))))))
(merge-paths (base-path relative-path)
((and base-path (string= base-path ""))
(format nil "/~A" relative-path))
((find #\/ base-path)
(concatenate 'string (subseq base-path 0 (1+ (position #\/ base-path :from-end t))) relative-path))
(t relative-path)))
(remove-dot-segments (path)
(loop for x across path
with previous-tokens = (make-array 5 :fill-pointer 0 :adjustable t :element-type 'character)
with result
do (progn
;(break "in-loop" x previous-tokens result (arrayp previous-tokens))
(vector-push-extend x previous-tokens)
((or (string= previous-tokens "../")
(string= previous-tokens "./"))
(setf (fill-pointer previous-tokens) 0))
((or (string= previous-tokens "/./")
(string= previous-tokens "/."))
(setf (fill-pointer previous-tokens) 0)
(vector-push #\/ previous-tokens))
((or (string= previous-tokens "/../")
(string= previous-tokens "/.."))
(setf (fill-pointer previous-tokens) 0)
(vector-push #\/ previous-tokens)
(setf result (subseq result 0 (position #\/ result :from-end t))))
((or (string= previous-tokens ".") ;do nothing
(string= previous-tokens "..")))
((and (eql (char previous-tokens 0) #\/)
(eql (char previous-tokens (1- (length previous-tokens))) #\/))
(setf result (concatenate 'string result (subseq previous-tokens 0 (1- (length previous-tokens)))))
(setf (fill-pointer previous-tokens) 0)
(vector-push #\/ previous-tokens))))
finally (progn
(return (if (or (string= previous-tokens ".") (string= previous-tokens ".."))
(concatenate 'string result previous-tokens)))))))
(unless (relative? uri) (return-from resolve uri))
(if (keywordp (uri-scheme base-uri))
(make-uri :scheme (uri-scheme base-uri)
:heir-part (merge-heir-parts base-uri uri)
:query (or (uri-query uri) (uri-query base-uri))
:fragment (uri-fragment uri))
(funcall (uri-scheme base-uri)
(merge-heir-parts base-uri uri)
:query (or (uri-query uri) (uri-query base-uri))
:fragment (uri-fragment uri)))))
(defun gentag (authority)
"generates a unique tag uri"
(let ((sym (gensym (format nil "~A_" (get-universal-time)))))
(tag-uri authority (string sym))))
(defun tag-uri (authority name &optional date)
(format nil "tag:~A,~A:~A" authority (or date (atscl:full-date nil)) name))
(defun tag-name (tag)
(let ((tag-body (heir-part tag)))
(subseq tag-body (1+ (position #\: tag-body)))))
Markdown is supported
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment