source: cl-darcs/tags/0.1.0/upath.lisp

;;; Copyright (C) 2006 Magnus Henoch
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation; either version 2 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA

(in-package :darcs)

;; "Universal pathname" - can refer to either a local or a remote
;; file.  For local files, just use pathnames.  For remote files, use
;; the PURI library.

(defun make-upath (path)
  "Turn PATH into a \"universal pathname\".
If PATH is a pathname or URI, return it unchanged.
If PATH starts with \"http://\" or \"https://\", return a URI.
Else, return a pathname."
  (ctypecase path
    (pathname
     path)
    (puri:uri
     path)
    (string
     (if (or (string= path "http://" :end1 7)
             (string= path "https://" :end1 8))
         (puri:parse-uri path)
         (pathname path)))))

(defun upath-subdir (base subdirs &optional filename)
  "From BASE, descend into SUBDIRS and FILENAME."
  (setf base (make-upath base))
  (let* ((subdirs-list (remove-if #'keywordp 
                                  (if (pathnamep subdirs)
                                      (pathname-directory subdirs)
                                      subdirs))))
    (ctypecase base
      (puri:uri
       (let* ((current-path (puri:uri-parsed-path base))
              (new-path
               (cond
                 ((null current-path)
                  (cons :absolute subdirs-list))
                 (t
                  (append current-path subdirs-list))))
              (new-uri (puri:copy-uri base)))
         (setf (puri:uri-parsed-path new-uri) (if filename 
                                                  (append new-path (list filename))
                                                  new-path))
         new-uri))
      ;; this won't work correctly if BASE has a filename
      (pathname
       (merge-pathnames
        (make-pathname :directory (cons :relative subdirs-list)
                       :name filename)
        base)))))

(defun open-upath (upath &key binary (redirect-max-depth 5))
  "Open UPATH for reading.  Return a stream.
If BINARY is true, use an element type of (UNSIGNED-BYTE 8),
else CHARACTER."
  (setf upath (make-upath upath))
  (ctypecase upath
    (puri:uri 
     (dformat "~&Opening ~A..." upath)
     (let ((client-request (net.aserve.client:make-http-client-request upath :proxy *http-proxy*)))
       (net.aserve.client:read-client-response-headers client-request)
       (let ((code (net.aserve.client:client-request-response-code client-request)))
         (cond
           ((= code 200)
            (make-instance (if binary 'http-byte-input-stream 'http-char-input-stream)
                           :client-request client-request))
           ((and (> redirect-max-depth 0) (member code '(301 302 303 307)))
            (let ((new-location (cdr (assoc :location (net.aserve.client:client-request-headers client-request)))))
              (dformat "~&Redirected to ~A." new-location)
              (net.aserve.client:client-request-close client-request)
              (open-upath
               (puri:uri new-location)
               :redirect-max-depth (1- redirect-max-depth) :binary binary)))
           (t
            (error "Couldn't read ~A: ~A ~A."
                   upath
                   (net.aserve.client:client-request-response-code client-request)
                   (net.aserve.client:client-request-response-comment client-request)))))))

    (pathname
     (open upath :direction :input :if-does-not-exist :error
           :element-type (if binary '(unsigned-byte 8) 'character)))))


(defclass http-input-stream (trivial-gray-streams:trivial-gray-stream-mixin
                             trivial-gray-streams:fundamental-input-stream)
  ((client-request :initarg :client-request)
   (binary)
   (unread :initform nil))
  (:documentation "A Gray stream wrapping an Allegroserve HTTP request."))

(defclass http-char-input-stream (http-input-stream
                                  trivial-gray-streams:fundamental-character-input-stream)
  ((binary :initform nil))
  (:documentation "An HTTP input stream for characters."))

(defclass http-byte-input-stream (http-input-stream
                                  trivial-gray-streams:fundamental-binary-input-stream)
  ((binary :initform t))
  (:documentation "An HTTP input stream for bytes."))

(defmethod trivial-gray-streams:stream-read-sequence 
    ((stream http-input-stream) sequence start end &key &allow-other-keys)
  (if (slot-value stream 'binary)
      (net.aserve.client:client-request-read-sequence 
       sequence (slot-value stream 'client-request))
      (let* ((buffer (make-array (- end start) :element-type '(unsigned-byte 8)))
             (len (net.aserve.client:client-request-read-sequence 
                   buffer (slot-value stream 'client-request))))
        (loop for i from 0 below len
           do (setf (elt sequence (+ i start)) (aref buffer i)))
        len)))

(defmethod trivial-gray-streams:stream-read-byte ((stream http-input-stream))
  (let ((buffer (make-array 1 :element-type '(unsigned-byte 8))))
    (if (= 1 (trivial-gray-streams:stream-read-sequence stream buffer 0 1))
        (aref buffer 0)
        :eof)))

(defmethod trivial-gray-streams:stream-read-char ((stream http-input-stream))
  (or (pop (slot-value stream 'unread))
      (let ((byte (trivial-gray-streams:stream-read-byte stream)))
        (if (eql byte :eof) byte (code-char byte)))))

(defmethod trivial-gray-streams:stream-unread-char ((stream http-input-stream) char)
  (push char (slot-value stream 'unread)))

(defmethod stream-element-type ((stream http-input-stream))
  (if (slot-value stream 'binary) '(unsigned-byte 8) 'character))

(defmethod close ((stream http-input-stream) &key &allow-other-keys)
  (net.aserve.client:client-request-close (slot-value stream 'client-request))
  (call-next-method))