Module: access-remote

 Uniform access to local and remote resources
 Resolution for relative URIs in accordance with RFC 2396

 This software is in Public Domain.
 IT IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND.

 Please send bug reports and comments to:
   lizorkin@hotbox.ru    Dmitry Lizorkin


Accessing (remote) resources
f: resource-exists?
f: open-input-resource

Determining resource type
f: ar:file-extension
f: ar:resource-type

Working on absolute/relative URIs
The URI and its components
f: ar:uri->components
f: ar:components->uri
Path and its path_segments
f: ar:path->segments
f: ar:segments->path
f: ar:normalize-dir-lst
Resolves a relative URI with respect to the base URI
f: ar:resolve-uri-according-base

Accessing (remote) resources


resource-exists?

(define (resource-exists? req-uri)
... Full Code ... )
 Whether the resource exists (generalization of FILE-EXISTS? predicate)
  REQ-URI - a string representing a URI of the resource
 This predicate doesn't have any side effects


open-input-resource

(define (open-input-resource req-uri)
... Full Code ... )
 Opens an input port for a resource
  REQ-URI - a string representing a URI of the resource
 An input port is returned if there were no errors. In case of an error,
 the function returns #f and displays an error message as a side effect.
 Doesn't raise any exceptions.



Determining resource type


ar:file-extension

(define (ar:file-extension filename)
... Full Code ... )
 Returns a file extenstion
  filename - a string
 File extension is returned in the form of a string


ar:resource-type

(define (ar:resource-type req-uri)
... Full Code ... )
 Determines the type of a resource
  REQ-URI - a string representing a URI of the resource
 For a local resource, its type is determined by its file extension
 One of the following is returned:
  #f - if the requested resource doesn't exist
  'xml - for a resource that is an XML document
  'html - for a resource that is an HTML document
  'unknown - for any other resource type



Working on absolute/relative URIs

 This section is based on RFC 2396

The URI and its components

  URI-reference = [ absoluteURI | relativeURI ] [ "#" fragment ]
  genericURI = <scheme>://<authority><path>?<query>
 For a sertain subset of URI schemes, absoluteURI = genericURI
 We will suppose this condition valid in this implementation

ar:uri->components

(define (ar:uri->components uri)
... Full Code ... )
 Returns: (values scheme authority path query fragment)
 If some component is not presented in the given URI, #f is returned for this
 component. Note that the path component is always presented in the URI


ar:components->uri

(define (ar:components->uri scheme authority path query fragment)
... Full Code ... )
 Combines components into the URI



Path and its path_segments

  abs_path = "/" path_segments
  path_segments = segment *( "/" segment ) 

ar:path->segments

(define (ar:path->segments path)
... Full Code ... )
 Splits the given path into segments
 Returns: (values root dir-lst filename)
  dir-lst ::= (listof directory-name)
  root - either an empty string, or "/" or drive-name (for Windows filesystems)


ar:segments->path

(define (ar:segments->path root dir-lst filename backslash?)
... Full Code ... )
 Combines path_segments into the path
  backslash? - a boolean value: whether the backslach shall be used as a
 delimiter between path_segments. If #f, straight slash is used


ar:normalize-dir-lst

(define (ar:normalize-dir-lst dir-lst)
... Full Code ... )
 Removes redundant segment combinations from the dir-lst
  '("smth" "..") --> removed
  '(".") --> removed
 The algorithm is formally specified in RFC 2396, 5.2, step 6)



Resolves a relative URI with respect to the base URI


ar:resolve-uri-according-base

(define (ar:resolve-uri-according-base base-uri req-uri)
... Full Code ... )
  base-uri - base URI for the requiested one
 Returns the resolved URI


Code

resource-exists?

Index
 Whether the resource exists (generalization of FILE-EXISTS? predicate)
  REQ-URI - a string representing a URI of the resource
 This predicate doesn't have any side effects
(define (resource-exists? req-uri)
  (cond
    ((string-prefix? "http://" req-uri)  ; HTTP scheme is used in REQ-URI
     (with-exception-handler
      (lambda (x) #f)  ; an uncaught exception occured during http transaction
      (lambda ()
        (http-transaction
         "HEAD"
         req-uri
         (list (cons 'logger (lambda (port message . other-messages) #t)))
         (lambda (resp-code resp-headers resp-port)
           (close-input-port resp-port)
           (and (>= resp-code 200) (< resp-code 400)))))))
    (else  ; a local file
     (file-exists? req-uri))))

open-input-resource

Index
 Opens an input port for a resource
  REQ-URI - a string representing a URI of the resource
 An input port is returned if there were no errors. In case of an error,
 the function returns #f and displays an error message as a side effect.
 Doesn't raise any exceptions.
(define (open-input-resource req-uri)
  (with-exception-handler
   (lambda (x)
     (cerr nl req-uri ": " ((condition-property-accessor 'exn 'message) x) nl)
     #f)
   (lambda ()
     (cond
       ((string-prefix? "http://" req-uri)  ; HTTP scheme is used in REQ-URI
        (http-transaction
         "GET"
         req-uri
         (list (cons 'logger (lambda (port message . other-messages) #t)))
         (lambda (resp-code resp-headers resp-port)
           (cond
             ((and (>= resp-code 200) (< resp-code 400)) resp-port)
             (else
              (close-input-port resp-port)
              (cerr nl req-uri ": resource not available: " resp-code nl)
              #f)))))
       (else  ; a local file     
        (open-input-file req-uri))))))

ar:file-extension

Index
 Returns a file extenstion
  filename - a string
 File extension is returned in the form of a string
(define (ar:file-extension filename)
  (let loop ((src (reverse (string->list filename)))
             (res '()))
    (cond
      ((null? src)  ; no dot encountered => no extension
       "")
      ((char=? (car src) #\.)
       (list->string res))
      (else
       (loop (cdr src) (cons (car src) res))))))

ar:resource-type

Index
 Determines the type of a resource
  REQ-URI - a string representing a URI of the resource
 For a local resource, its type is determined by its file extension
 One of the following is returned:
  #f - if the requested resource doesn't exist
  'xml - for a resource that is an XML document
  'html - for a resource that is an HTML document
  'unknown - for any other resource type
(define (ar:resource-type req-uri)
  (cond
    ((string-prefix? "http://" req-uri)  ; HTTP scheme is used in REQ-URI
     (with-exception-handler
      (lambda (x) #f)  ; an uncaught exception occured during http transaction
      (lambda ()
        (http-transaction
         "HEAD"
         req-uri
         (list (cons 'logger (lambda (port message . other-messages) #t)))
         (lambda (resp-code resp-headers resp-port)
           (close-input-port resp-port)
           (if
            (or (< resp-code 200) (>= resp-code 400))
            #f  ; Resource doesn't exist              
            (let ((content-type (assq 'CONTENT-TYPE resp-headers)))
              (cond
                ((not content-type)  ; no content type specified
                 'unknown)
                ((string-prefix? "text/xml" (cdr content-type))
                 'xml)
                ((string-prefix? "text/html" (cdr content-type))
                 'html)
                ((string-prefix? "text/plain" (cdr content-type))
                 'plain)
                (else
                 'unknown)))))))))
    (else  ; a local file
     (cond
       ((not (file-exists? req-uri))  ; file doesn't exist
        #f)
       ((assoc (ar:file-extension req-uri)
               '(("xml" . xml) ("html" . html) ("htm" . html)))
        => cdr)
       (else 'unknown)))))

ar:uri->components

Index
 Returns: (values scheme authority path query fragment)
 If some component is not presented in the given URI, #f is returned for this
 component. Note that the path component is always presented in the URI
(define (ar:uri->components uri)
  (call-with-values
   (lambda () (cond
                ((string-rindex uri #\#)
                 => (lambda (pos)
                      (values
                       (substring uri (+ pos 1) (string-length uri))
                       (substring uri 0 pos))))
                (else
                 (values #f uri))))
   (lambda (fragment uri)
     (call-with-values
      (lambda () (cond
                   ((string-rindex uri #\?)
                    => (lambda (pos)
                         (values
                          (substring uri (+ pos 1) (string-length uri))
                          (substring uri 0 pos))))
                   (else
                    (values #f uri))))
      (lambda (query uri)
        (call-with-values
         (lambda ()
           (cond
             ((substring? "://" uri)
              => (lambda (pos)
                   (values
                    (substring uri 0 (+ pos 3))
                    (substring uri (+ pos 3) (string-length uri)))))
             ((string-index uri #\:)
              => (lambda (pos)
                   (values
                    (substring uri 0 (+ pos 1))
                    (substring uri (+ pos 1) (string-length uri)))))
             (else
              (values #f uri))))
         (lambda (scheme uri)
           (call-with-values
            (lambda ()
              (cond
                ((not scheme)
                 (values #f uri))
                ((string-index uri #\/)
                 => (lambda (pos)
                      (values
                       (substring uri 0 pos)
                       (substring uri pos (string-length uri)))))
                (else
                 (values #f uri))))
            (lambda (authority path)
              (values scheme authority path query fragment))))))))))

ar:components->uri

Index
 Combines components into the URI
(define (ar:components->uri scheme authority path query fragment)
  (apply string-append
         (append
          (if scheme (list scheme) '())
          (if authority (list authority) '())
          (list path)
          (if query (list "?" query) '())
          (if fragment (list "#" fragment) '()))))

ar:path->segments

Index
 Splits the given path into segments
 Returns: (values root dir-lst filename)
  dir-lst ::= (listof directory-name)
  root - either an empty string, or "/" or drive-name (for Windows filesystems)
(define (ar:path->segments path)
  (call-with-values
   (lambda ()
     (let ((lng (string-length path)))
       (cond
         ((and (> lng 0) (char=? (string-ref path 0) #\/))
           (values "/" (substring path 1 lng)))
       ((and (> lng 1)
             (char=? (string-ref path 1) #\:)
             (member (string-ref path 2) (list #\/ #\\)))
        (values (substring path 0 3)
                (substring path 3 lng)))
       (else (values "" path)))))
   (lambda (root rel-path)
     (let ((lst (string-split rel-path (list #\/ #\\))))
       (if (null? lst)  ; the relative path is empty
           (values root '() "")
           (let ((lst (reverse lst)))
             (values root (reverse (cdr lst)) (car lst))))))))

ar:segments->path

Index
 Combines path_segments into the path
  backslash? - a boolean value: whether the backslach shall be used as a
 delimiter between path_segments. If #f, straight slash is used
(define (ar:segments->path root dir-lst filename backslash?)
  (let ((delim (if backslash? "\\" "/")))
    (apply string-append
           (append
            (list root)
            (apply append
                   (map
                    (lambda (directory-name)
                      (list directory-name delim))
                    dir-lst))
            (list filename)))))

ar:normalize-dir-lst

Index
 Removes redundant segment combinations from the dir-lst
  '("smth" "..") --> removed
  '(".") --> removed
 The algorithm is formally specified in RFC 2396, 5.2, step 6)
(define (ar:normalize-dir-lst dir-lst)
  (cond
    ((null? dir-lst) dir-lst)
    ((string=? (car dir-lst) ".")
     (ar:normalize-dir-lst (cdr dir-lst)))
    ((string=? (car dir-lst) "..")
     (cons (car dir-lst) (ar:normalize-dir-lst (cdr dir-lst))))
    (else
     (let ((processed (ar:normalize-dir-lst (cdr dir-lst))))
       (cond
         ((null? processed)
          (list (car dir-lst)))
         ((string=? (car processed) "..")
          (cdr processed))
         (else
          (cons (car dir-lst) processed)))))))

ar:resolve-uri-according-base

Index
  base-uri - base URI for the requiested one
 Returns the resolved URI
(define (ar:resolve-uri-according-base base-uri req-uri)
  (call-with-values
   (lambda () (ar:uri->components req-uri))
   (lambda (req-scheme req-authority req-path req-query req-fragment)
     (if
      (or req-scheme req-authority)  ; it is the absolute URI
      req-uri
      (call-with-values
       (lambda () (ar:path->segments req-path))
       (lambda (req-root req-dir-lst req-filename)
         (if
          (> (string-length req-root) 1)  ; absolute path from the disc drive
          req-uri
          (call-with-values
           (lambda () (ar:uri->components base-uri))
           (lambda 
               (base-scheme base-authority base-path base-query base-fragment)
             (if
              (string=? req-root "/")  ; absolute path from server
              (ar:components->uri base-scheme base-authority
                                  req-path req-query req-fragment)
              ; else the requested URI is the relative URI
              (call-with-values
               (lambda () (ar:path->segments base-path))
               (lambda (base-root base-dir-lst base-filename)
                 (ar:components->uri
                  base-scheme
                  base-authority
                  (ar:segments->path
                   base-root
                   (ar:normalize-dir-lst (append base-dir-lst req-dir-lst))
                   req-filename
                   (and (not (string-index base-path #\/))
                        (string-index req-path #\\)))
                  req-query
                  req-fragment)))))))))))))