#!/bin/sh
#| -*- mode: scheme; coding: utf-8; -*- |#
:; exec gosh -- $0 "$@"
;;;
;;;ugly hack to make grass better scriptable
;;;
;;;   Copyright (c) 2012 Jens Thiele <karme@karme.de>
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(use srfi-1)
(use srfi-13)
(use srfi-27)
(use file.util)
(use gauche.process)
(use gauche.sequence)

(define-macro (assert e)
  `(when (not ,e)
     (error "assertion failed: " ,(x->string e))))

(define *initial-location-files* '(("DEFAULT_WIND" . "proj:       3
zone:       0
north:      1N
south:      0
east:       1E
west:       0
cols:       1
rows:       1
e-w resol:  1
n-s resol:  1
top:        1
bottom:     0
cols3:      1
rows3:      1
depths:     1
e-w resol3: 1
n-s resol3: 1
t-b resol:  1
")
                                   ("PROJ_INFO" . "name: Lat/Lon
proj: ll
datum: wgs84
ellps: wgs84
no_defs: defined
")
                                   ("PROJ_UNITS" . "unit: degree
units: degrees
meters: 1.0
")
                                   ("WIND" . "proj:       3
zone:       0
north:      1N
south:      0
east:       1E
west:       0
cols:       1
rows:       1
e-w resol:  1
n-s resol:  1
top:        1
bottom:     0
cols3:      1
rows3:      1
depths:     1
e-w resol3: 1
n-s resol3: 1
t-b resol:  1
")))

(random-source-randomize! default-random-source)

(define (random-string)
  (format "~x" (random-integer #xfffffffff)))

(define (eprint . l)
  (with-output-to-port (current-error-port)
    (cut apply print l)))

;; (define (my-rmdir dir)
;;   (guard (e
;; 	  [else
;; 	   (eprint "rmdir " dir " failed") ;; todo
;; 	   ])
;; 	 (sys-rmdir dir)))

(define my-rmdir sys-rmdir)

;; todo: name is somewhat misleading/ambiguous / should be in file.util?
(define (with-temporary-directory thunk)
  (define (mk-random-tmpdir)
    (let loop ((try 0))
      (guard (e
              [(<system-error> e)
               (if (< try 10000)
                 (loop (+ try 1))
                 (raise e))])
             (let1 r (string-append (temporary-directory)
                                    "/grtc" ;; todo: add pattern keyword
                                    (random-string))
               (sys-mkdir r #o0700)
               r))))
  
  (let1 dir (mk-random-tmpdir)
    (unwind-protect
     (thunk dir)
     (my-rmdir dir))))

(define (with-current-directory name thunk)
  (let1 old-dir (current-directory)
    (unwind-protect
     (begin
       ;; fake make to let emacs know we changed directory
       (eprint #`"grass: Entering directory `,|name|'")
       (current-directory name)
       (thunk))
     (begin
       (eprint #`"grass: Leaving directory `,|name|'")
       (current-directory old-dir)))))

;; run something in a dummy initial location
(define (with-grass-initial-location thunk)
  (with-temporary-directory
   (lambda(dir)
     (with-current-directory
      dir
      (lambda()
        (sys-mkdir "dummy"  #o0700)
        (with-current-directory
         "dummy"
         (lambda()
           (sys-mkdir "PERMANENT" #o0700)
           (with-current-directory
            "PERMANENT"
            (lambda()
              (for-each
               (lambda(x)
                 (with-output-to-file (car x)
                   (lambda()
                     (write (cdr x)))))
               *initial-location-files*)))))
        (thunk (string-append dir "/dummy/PERMANENT"))
        (with-current-directory
         "dummy"
         (lambda()
           (with-current-directory
            "PERMANENT"
            (lambda()
              (for-each
               (compose sys-unlink car)
               *initial-location-files*)))
           (my-rmdir "PERMANENT")))
        (my-rmdir "dummy"))))))

(define (grass-rcfile)
  (string-append (sys-getenv "HOME") "/.grassrc6"))

(define (location-explode location)
  (let1 l (string-split location "/")
    (assert (= (size-of l) 5))
    (assert (string-null? (car l)))
    (values (string-join (subseq l 0 3) "/") ;; database
            (ref l 3) ;; location
            (ref l 4) ;; mapset
            )))

(define (fake-rcfile location)
  (receive (db location mapset) (location-explode location)
    (with-output-to-file (grass-rcfile)
      (lambda()
        (print "GISDBASE: " db)
        (print "LOCATION_NAME: " location)
        (print "MAPSET: " mapset)
        )
      :if-exists :error))
  ;; (cat (grass-rcfile))
  )

(define (cat x)
  (copy-port (open-input-file x) (current-output-port)))

(define (run l)
  (let1 p (run-process l :wait #f)
    #?=(process-wait p #f #t)))

;; todo: not safe
(define (grass-run-script-within-location script location)
  ;;#?=(list script location)
  (sys-putenv "GRASS_BATCH_JOB" script)
  ;; todo: reads $HOME/.grassrc6 :(
  ;; use --rcfile? doesn't help?
  ;;(sys-putenv "LOCATION" location)
  (let* ((rcfile (grass-rcfile))
         (restore-rcfile (cond [(file-exists? rcfile)
                                (sys-rename rcfile (string-append rcfile ".old"))
                                (fake-rcfile location)
                                (lambda()
                                  (sys-rename (string-append rcfile ".old") rcfile))]
                               [else
                                (fake-rcfile location)
                                (lambda()
                                  (sys-unlink rcfile)
                                  )])))
    (unwind-protect
     (run `(grass -text ,location))
     (restore-rcfile))))

(define (with-output-to-tmpfile thunk)
  (receive (port fname) (sys-mkstemp "/tmp/grass-script")
    (with-output-to-port port thunk)
    (close-output-port port)
    fname))

(define (grass-create-epsg-location initial-location epsg location)
  (assert (number? epsg))
  (let1 fname
      (with-output-to-tmpfile
       (lambda()
         ;; danger
         (print #`"g.proj -c epsg=,|epsg| location=,|location|")))
    (sys-chmod fname #o0700)
    (grass-run-script-within-location fname initial-location)
    (sys-unlink fname)))

(define run-find (cut run '(find)))

(define (with-grass-epsg-location epsg thunk)
  (with-temporary-directory
   (lambda(dir)
     (with-grass-initial-location
      (lambda(location)
	;; (print "initial location: `" location "'")
	;;(run-find)
	(grass-create-epsg-location location epsg #`"epsg,|epsg|")
        ;;(run-find)
	;; (run `(mv -v ,#`"epsg,|epsg|" ,dir))
        (sys-rename #`"epsg,|epsg|" (string-append dir #`"/epsg,|epsg|"))
        ;;#?=(current-directory)
	;; danger!
	(for-each sys-unlink
		  (map (cut string-append location "/" <>)
		       '(".bashrc" "VAR")))
	(for-each
	 (lambda(x)
	   (run `(rm -rfv ,|x|)))
	 (map (cut string-append location "/" <>)
	      '("dbf" ".tmp")))
	(run `(find ,|location|))
        ))
     (unwind-protect
      (with-current-directory
       (string-append dir #`"/epsg,|epsg|")
       (lambda()
         (thunk (string-append dir #`"/epsg,|epsg|/PERMANENT"))))
      (run #?=`(rm -rfv ,(string-append dir #`"/epsg,|epsg|"))))
     )))

(define (utm-zone->epsg x)
  (+ 32600 x))

(define (with-output-to-tmpfile thunk)
  (receive (port fname) (sys-mkstemp "/tmp/grass-script")
    (with-output-to-port port thunk)
    (close-output-port port)
    fname))

(define (extract-epsg args)
  (if-let1 m (find-tail (cut equal? "-epsg" <>) args)
    (x->number (cadr m))
    4326))

(define (remaining-args args)
  (if-let1 m (find-tail (cut equal? "--" <>) args)
    (cdr m)
    args))

(define (main args)
  #?=args
  (let* ((script1 (with-output-to-tmpfile
                   (lambda()
                     (with-input-from-file (ref args 1)
                       (lambda()
                         (read-line)
                         (copy-port (current-input-port) (current-output-port)))))))
         (script2 (with-output-to-tmpfile
                   (lambda()
                     (print "#!/bin/sh")
                     (print script1 " " (string-join (map shell-escape-string (remaining-args (cddr args))) " "))
                     ))))
    (sys-chmod script1 #o0700)
    (sys-chmod script2 #o0700)
    (cat script1)
    (cat script2)
    (with-grass-epsg-location (extract-epsg (cdr args))
                              (lambda(location)
                                (grass-run-script-within-location script2 location)))
    (sys-unlink script1)
    (sys-unlink script2)
    )
  0)
