;;; 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))