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

Last change on this file was 1, checked in by Magnus Henoch, 16 years ago

Initial import

File size: 5.7 KB
Line 
1;;; Copyright (C) 2006 Magnus Henoch
2;;;
3;;; This program is free software; you can redistribute it and/or
4;;; modify it under the terms of the GNU General Public License as
5;;; published by the Free Software Foundation; either version 2 of the
6;;; License, or (at your option) any later version.
7;;;
8;;; This program is distributed in the hope that it will be useful,
9;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11;;; General Public License for more details.
12;;;
13;;; You should have received a copy of the GNU General Public License
14;;; along with this program; if not, write to the Free Software
15;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
16
17(in-package :darcs)
18
19;; "Universal pathname" - can refer to either a local or a remote
20;; file.  For local files, just use pathnames.  For remote files, use
21;; the PURI library.
22
23(defun make-upath (path)
24  "Turn PATH into a \"universal pathname\".
25If PATH is a pathname or URI, return it unchanged.
26If PATH starts with \"http://\" or \"https://\", return a URI.
27Else, return a pathname."
28  (ctypecase path
29    (pathname
30     path)
31    (puri:uri
32     path)
33    (string
34     (if (or (string= path "http://" :end1 7)
35             (string= path "https://" :end1 8))
36         (puri:parse-uri path)
37         (pathname path)))))
38
39(defun upath-subdir (base subdirs &optional filename)
40  "From BASE, descend into SUBDIRS and FILENAME."
41  (setf base (make-upath base))
42  (let* ((subdirs-list (remove-if #'keywordp 
43                                  (if (pathnamep subdirs)
44                                      (pathname-directory subdirs)
45                                      subdirs))))
46    (ctypecase base
47      (puri:uri
48       (let* ((current-path (puri:uri-parsed-path base))
49              (new-path
50               (cond
51                 ((null current-path)
52                  (cons :absolute subdirs-list))
53                 (t
54                  (append current-path subdirs-list))))
55              (new-uri (puri:copy-uri base)))
56         (setf (puri:uri-parsed-path new-uri) (if filename 
57                                                  (append new-path (list filename))
58                                                  new-path))
59         new-uri))
60      ;; this won't work correctly if BASE has a filename
61      (pathname
62       (merge-pathnames
63        (make-pathname :directory (cons :relative subdirs-list)
64                       :name filename)
65        base)))))
66
67(defun open-upath (upath &key binary (redirect-max-depth 5))
68  "Open UPATH for reading.  Return a stream.
69If BINARY is true, use an element type of (UNSIGNED-BYTE 8),
70else CHARACTER."
71  (setf upath (make-upath upath))
72  (ctypecase upath
73    (puri:uri 
74     (dformat "~&Opening ~A..." upath)
75     (let ((client-request (net.aserve.client:make-http-client-request upath :proxy *http-proxy*)))
76       (net.aserve.client:read-client-response-headers client-request)
77       (let ((code (net.aserve.client:client-request-response-code client-request)))
78         (cond
79           ((= code 200)
80            (make-instance (if binary 'http-byte-input-stream 'http-char-input-stream)
81                           :client-request client-request))
82           ((and (> redirect-max-depth 0) (member code '(301 302 303 307)))
83            (let ((new-location (cdr (assoc :location (net.aserve.client:client-request-headers client-request)))))
84              (dformat "~&Redirected to ~A." new-location)
85              (net.aserve.client:client-request-close client-request)
86              (open-upath
87               (puri:uri new-location)
88               :redirect-max-depth (1- redirect-max-depth) :binary binary)))
89           (t
90            (error "Couldn't read ~A: ~A ~A."
91                   upath
92                   (net.aserve.client:client-request-response-code client-request)
93                   (net.aserve.client:client-request-response-comment client-request)))))))
94
95    (pathname
96     (open upath :direction :input :if-does-not-exist :error
97           :element-type (if binary '(unsigned-byte 8) 'character)))))
98
99
100(defclass http-input-stream (trivial-gray-streams:trivial-gray-stream-mixin
101                             trivial-gray-streams:fundamental-input-stream)
102  ((client-request :initarg :client-request)
103   (binary)
104   (unread :initform nil))
105  (:documentation "A Gray stream wrapping an Allegroserve HTTP request."))
106
107(defclass http-char-input-stream (http-input-stream
108                                  trivial-gray-streams:fundamental-character-input-stream)
109  ((binary :initform nil))
110  (:documentation "An HTTP input stream for characters."))
111
112(defclass http-byte-input-stream (http-input-stream
113                                  trivial-gray-streams:fundamental-binary-input-stream)
114  ((binary :initform t))
115  (:documentation "An HTTP input stream for bytes."))
116
117(defmethod trivial-gray-streams:stream-read-sequence 
118    ((stream http-input-stream) sequence start end &key &allow-other-keys)
119  (if (slot-value stream 'binary)
120      (net.aserve.client:client-request-read-sequence 
121       sequence (slot-value stream 'client-request))
122      (let* ((buffer (make-array (- end start) :element-type '(unsigned-byte 8)))
123             (len (net.aserve.client:client-request-read-sequence 
124                   buffer (slot-value stream 'client-request))))
125        (loop for i from 0 below len
126           do (setf (elt sequence (+ i start)) (aref buffer i)))
127        len)))
128
129(defmethod trivial-gray-streams:stream-read-byte ((stream http-input-stream))
130  (let ((buffer (make-array 1 :element-type '(unsigned-byte 8))))
131    (if (= 1 (trivial-gray-streams:stream-read-sequence stream buffer 0 1))
132        (aref buffer 0)
133        :eof)))
134
135(defmethod trivial-gray-streams:stream-read-char ((stream http-input-stream))
136  (or (pop (slot-value stream 'unread))
137      (let ((byte (trivial-gray-streams:stream-read-byte stream)))
138        (if (eql byte :eof) byte (code-char byte)))))
139
140(defmethod trivial-gray-streams:stream-unread-char ((stream http-input-stream) char)
141  (push char (slot-value stream 'unread)))
142
143(defmethod stream-element-type ((stream http-input-stream))
144  (if (slot-value stream 'binary) '(unsigned-byte 8) 'character))
145
146(defmethod close ((stream http-input-stream) &key &allow-other-keys)
147  (net.aserve.client:client-request-close (slot-value stream 'client-request))
148  (call-next-method))
Note: See TracBrowser for help on using the repository browser.