;;; Copyright (C) 2006, 2008 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.  (Or the real thing, if we're using ACL)

(defun make-upath (path &key truename)
  "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.

If TRUENAME is provided and true, give an absolute path."
  (ctypecase path
    (pathname
     (if truename
	 (truename path)
	 path))
    (net.uri:uri
     path)
    (string
     (if (or (and (>= (length path) 7)
		  (string= path "http://" :end1 7))
	     (and (>= (length path) 8)
		  (string= path "https://" :end1 8)))
	 (net.uri:parse-uri path)
	 (if truename
	     (truename (pathname path))
	     (pathname path))))))

(defun upath-subdir (base subdirs &optional filename)
  "From BASE, descend into SUBDIRS and FILENAME.
PATH is assumed to refer to a directory, not a file."
  (setf base (make-upath base))
  (let* ((subdirs-list (remove-if #'keywordp 
				  (if (pathnamep subdirs)
				      (pathname-directory subdirs)
				      subdirs))))
    (ctypecase base
      (net.uri:uri
       (let* ((current-path (net.uri:uri-parsed-path base))
	      (new-path
	       (cond
		 ((null current-path)
		  (cons :absolute subdirs-list))
		 (t
		  (append current-path subdirs-list))))
	      (new-uri (net.uri:copy-uri base)))
	 (setf (net.uri: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
       (setf base (fad:pathname-as-directory base))
       (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
    (net.uri:uri 
     (dformat "~&Opening ~A..." upath)
     (apply #'drakma:http-request upath :redirect redirect-max-depth
	    :want-stream t (when *http-proxy* `(:proxy ,*http-proxy*))))

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

(defun upath-to-string (upath &key truename)
  "Convert UPATH to a string.
This string can be read with MAKE-UPATH.
When TRUENAME is provided and true, give absolute/canonical form."
  (ctypecase upath
    (string
     upath)
    (pathname
     (namestring (if truename
		     (truename upath)
		     upath)))
    (net.uri:uri
     (with-output-to-string (s)
       (net.uri:render-uri upath s)))))