initialize.lisp 8.55 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28
;;
;; Copyright 2002-2011 Genworks International 
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;; 
;; This source file 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
;; Affero General Public License for more details.
;; 
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file.  If not, see
;; <http://www.gnu.org/licenses/>.
;; 

(in-package :gwl)

(defvar *static-home* nil)

(defun ensure-static-relative-pathname (relative)
  (let ((pathname (merge-pathnames relative *static-home*)))
    (or (probe-file pathname)
29
	(warn "Expected static subdirectory ~a does not appear to exist.~%" pathname))))
30

31
(defun publish-images (server)
32 33 34 35 36
  (let ((destination (ensure-static-relative-pathname "gwl/images/")))
    (when destination (publish-directory
		       :prefix "/images/gwl/"
		       :server server
		       :destination (namestring destination)))))
37
		      
38
(defun publish-statics (server)
39 40
  (let ((destination (ensure-static-relative-pathname "")))
    (when destination (publish-directory
41
		       :headers (list (cons :cache-control "public, max-age=3600, must-revalidate"))
42 43 44
		       :prefix "/static/"
		       :server server
		       :destination (namestring destination)))))
45

46
(defun publish-style (server)
47 48 49 50 51
  (let ((destination (ensure-static-relative-pathname "gwl/style/")))
    (when destination (publish-directory
		       :prefix "/style/"
		       :server server
		       :destination (namestring destination)))))
52 53 54 55


(dolist (func (list 'publish-images 'publish-statics 'publish-style))
  (pushnew func *publishers*))
56 57 58 59


(defvar *aserve-listeners* 25)
(defvar *aserve-port* 9000)
60
(defvar *aserve-start-args* nil)
61

Dave Cooper's avatar
Dave Cooper committed
62

63 64 65 66
;;
;; FLAG -- get platform-specific stuff below into :glisp package. 
;;

Dave Cooper's avatar
Dave Cooper committed
67 68

#+nil
69
(defun client-test (port)
70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94

  #+allegro

  (multiple-value-bind (result error)
      (ignore-errors  
	(glisp:with-timeout (2 (error "AllegroServe port probe timed out on port ~a. 
Perhaps a zombie process is holding port ~a?~%" port port))

	  
	  (#+nil
	   net.aserve.client:do-http-request
	   drakma:http-request (format nil "http://localhost:~a" port))))

    
    (declare (ignore result))
    (when (typep error 'error)
      port))
  
  #-allegro
  (let* ((result
	  (handler-case
	      (let ((sock (usocket:socket-listen "localhost" port)))
		(usocket:socket-close sock))
	    (usocket:address-in-use-error (e) :in-use)
	    (t (e) :unknown))))
95
    (unless (member result '(:in-use :unknown)) port)))
96

97

98
(defun client-test (port)
99
  #-ccl
100 101 102 103
  (multiple-value-bind (result error)
      (ignore-errors  
	(glisp:with-timeout (2 (error "AllegroServe port probe timed out on port ~a. 
Perhaps a zombie process is holding port ~a?~%" port port))
104
	  (net.aserve.client:do-http-request (format nil "http://127.0.0.1:~a" port))))
105 106
    (declare (ignore result))
    (when (typep error 'error)
107 108 109 110
      port))
  #+ccl
  (let* ((result
	  (handler-case
111
	      (let ((sock (usocket:socket-listen "127.0.0.1" port)))
112
		(usocket:socket-close sock))
113 114
	    (usocket:address-in-use-error (e) (declare (ignore e)) :in-use)
	    (t (e) (declare (ignore e)) :unknown))))
115 116 117 118 119
    (unless (or (member result '(:in-use :unknown))
		#+windows-host
		(ignore-errors
		  (net.aserve.client:do-http-request
		      (format nil "http://127.0.0.1:~a" port)))) port)))
120

121 122 123 124
(defun start-gwl (&key (port *aserve-port*) (listeners *aserve-listeners*)
		    ;;
		    ;; FLAG -- figure out external-format for the other Lisps. 
		    ;;
125
		    (external-format #+allegro :utf8-base #-allegro :utf8) aserve-start-args)
Dave Cooper's avatar
Dave Cooper committed
126 127 128 129 130 131 132 133 134 135 136
  (net.aserve:shutdown)
  (let ((wait-time 1))
    (block :outer
      (do () (nil)
	(let ((port port))
	  (block :inner
	    (do ((port-free? (client-test port) (client-test port)))
		(port-free?
		 (format t (if (> wait-time 1) "~&Retrying AllegroServe on ~a...~%"
			       "~&Trying to start AllegroServe on ~a...~%") port)
		 (if (ignore-errors
137 138 139 140 141
		       (apply #'net.aserve:start
			      :port port :listeners listeners
			      ;;#-mswindows :external-format #-mswindows external-format ;; FLAG -- why no external-format for Windows?
			      :external-format external-format
			      aserve-start-args))
Dave Cooper's avatar
Dave Cooper committed
142 143 144
		     (return-from :outer port)
		     (progn (sleep (random wait-time)) (return-from :inner))))
	      (incf port))))
145 146
	(incf wait-time 0.1))))
  (publish-uris))
Dave Cooper's avatar
Dave Cooper committed
147 148 149


#+nil
150
(defun start-gwl (&key (port *aserve-port*) (listeners *aserve-listeners*) 
151 152
		    (external-format #+allegro :utf8-base #+ccl :utf-8 #-(or allegro ccl) (error "find utf-8 external-format for ~a.~%" (lisp-implementation-version)))
		    (aserve-start-args *aserve-start-args*))
153
  (net.aserve:shutdown :server net.aserve:*wserver*)
154
  (let ((wait-time 1))
155
      (block :outer
156
	(do () (nil)
157 158 159 160 161 162 163
	  (let ((port port))
	    (block :inner
	      (do ((port-free? (client-test port) (client-test port)))
		  (port-free?
		   (format t (if (> wait-time 1) "~&Retrying AllegroServe on ~a...~%"
				 "~&Trying to start AllegroServe on ~a...~%") port)
		   (if (ignore-errors
164
			 (setq net.aserve:*wserver*
165 166 167
			       (apply #'net.aserve:start :port port :listeners listeners :server :new
				      #-mswindows :external-format #-mswindows external-format
				      aserve-start-args)))
168 169 170
		    (return-from :outer port)
		    (progn (sleep (random wait-time)) (return-from :inner))))
		(incf port))))
171 172 173
	  (incf wait-time 0.1))))

  (publish-uris))
174

175 176 177 178

(defvar *settings* 
  (list (list '*static-home* *static-home* 
	      #'(lambda()
179 180 181
		  (or (and glisp:*gendl-source-home*
			   (probe-file (merge-pathnames "gwl/static/" 
							glisp:*gendl-source-home*)))
182 183 184
		      (and glisp:*gdl-home*
			   (probe-file (merge-pathnames "static/"
							glisp:*gdl-home*)))
Dave Cooper's avatar
Dave Cooper committed
185 186 187 188 189

		      (and glisp:*gdl-program-home*
			   (probe-file (merge-pathnames "static/"
							glisp:*gdl-program-home*)))
		      
190 191 192 193 194 195 196 197 198 199 200 201 202 203
		      (warn "~%Static home not found in source directory or parent of program directory.~%"))))))


;;
;; FLAG -- move publishes into global param with the basic publishing data and 
;;         call general-purpose publish function on this data. 
;;    also detect changes in the publishing to include in return value.
;;
(defun initialize ()
  ;;
  ;; FLAG -- investigate if this initialize-multiprocessing business
  ;; is still needed, currently LW-only.
  ;;
  (glisp:initialize-multiprocessing)
204 205 206 207 208

  (when (find-package :zacl)
    (setq excl:*initial-terminal-io* *terminal-io*)
    (setf (slot-value net.aserve:*wserver* 'net.aserve::log-stream) excl:*initial-terminal-io*
	  (slot-value (slot-value net.aserve:*wserver* 'net.aserve::default-vhost) 'net.aserve::log-stream) excl:*initial-terminal-io*))
209 210 211
  
  (setq *iid-random-state* (make-random-state t))
  
212 213
  (let (anything-changed?)
    (setq anything-changed? (glisp:set-settings *settings*))
214
    (start-gwl) 
215 216
    anything-changed?))

217 218


219 220 221 222
;;
;; FLAG -- get platform-specific stuff into glisp package. 
;;

223
#+(and ccl windows-target)
224 225 226
(in-package :ccl)


227
#-(and ccl windows-target)
228
(eval-when (:compile-toplevel :load-toplevel :execute)
229 230
  (defparameter *set-_?* nil)
  (defparameter *set-$?* nil)
231 232 233 234 235 236 237 238 239 240
  (unless (get-dispatch-macro-character #\# #\_)
    (setq *set-_?* t)
    (set-dispatch-macro-character #\# #\_ #'(lambda(s subchar arg) (declare (ignore s subchar arg))nil)))
  (unless (get-dispatch-macro-character #\# #\$)
    (setq *set-$?* t)
    (set-dispatch-macro-character #\# #\$ #'(lambda(s subchar arg) (declare (ignore s subchar arg)) nil))))

#+(and ccl windows-target)
(let (*warn-if-redefine-kernel*)
  (defun %windows-sleep (millis)
241 242

    #+nil
243 244
    (unless (typep millis 'unsigned-byte 32)
      (setq millis (coerce 1000000000 '(unsigned-byte 32))))
245 246 247 248 249 250

    (do ((new-value (round (/ millis 10)) (round (/ millis 10))))
	((typep millis '(unsigned-byte 32)))
      (setq millis new-value))

    
251 252 253 254 255 256 257 258 259
    (do* ((start (floor (get-internal-real-time)
			(floor internal-time-units-per-second 1000))
		 (floor (get-internal-real-time)
			(floor internal-time-units-per-second 1000)))
	  (millis millis (- stop start))
	  (stop (+ start millis)))
	 ((or (<= millis 0)
	      (not (eql (#_SleepEx millis #$true) #$WAIT_IO_COMPLETION)))))))

260
#-(and ccl windows-target)
261 262 263 264 265
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when *set-_?* (set-dispatch-macro-character #\# #\_ nil))
  (when *set-$?* (set-dispatch-macro-character #\# #\$ nil)))


266 267


268