initialize.lisp 8.31 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 41 42 43
  (let ((destination (ensure-static-relative-pathname "")))
    (when destination (publish-directory
		       :prefix "/static/"
		       :server server
		       :destination (namestring destination)))))
44

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


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


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

Dave Cooper's avatar
Dave Cooper committed
61

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

Dave Cooper's avatar
Dave Cooper committed
66 67

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

  #+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))))
94
    (unless (member result '(:in-use :unknown)) port)))
95

96

97
(defun client-test (port)
98
  #-ccl
99 100 101 102
  (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))
103
	  (net.aserve.client:do-http-request (format nil "http://127.0.0.1:~a" port))))
104 105
    (declare (ignore result))
    (when (typep error 'error)
106 107 108 109
      port))
  #+ccl
  (let* ((result
	  (handler-case
110
	      (let ((sock (usocket:socket-listen "127.0.0.1" port)))
111
		(usocket:socket-close sock))
112 113
	    (usocket:address-in-use-error (e) (declare (ignore e)) :in-use)
	    (t (e) (declare (ignore e)) :unknown))))
114 115 116 117 118
    (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)))
119

120 121 122 123
(defun start-gwl (&key (port *aserve-port*) (listeners *aserve-listeners*)
		    ;;
		    ;; FLAG -- figure out external-format for the other Lisps. 
		    ;;
124
		    (external-format #+allegro :utf8-base #-allegro :utf8) aserve-start-args)
Dave Cooper's avatar
Dave Cooper committed
125 126 127 128 129 130 131 132 133 134 135
  (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
136 137 138 139 140
		       (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
141 142 143
		     (return-from :outer port)
		     (progn (sleep (random wait-time)) (return-from :inner))))
	      (incf port))))
144 145
	(incf wait-time 0.1))))
  (publish-uris))
Dave Cooper's avatar
Dave Cooper committed
146 147 148


#+nil
149
(defun start-gwl (&key (port *aserve-port*) (listeners *aserve-listeners*) 
150 151
		    (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*))
152
  (net.aserve:shutdown :server net.aserve:*wserver*)
153
  (let ((wait-time 1))
154
      (block :outer
155
	(do () (nil)
156 157 158 159 160 161 162
	  (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
163
			 (setq net.aserve:*wserver*
164 165 166
			       (apply #'net.aserve:start :port port :listeners listeners :server :new
				      #-mswindows :external-format #-mswindows external-format
				      aserve-start-args)))
167 168 169
		    (return-from :outer port)
		    (progn (sleep (random wait-time)) (return-from :inner))))
		(incf port))))
170 171 172
	  (incf wait-time 0.1))))

  (publish-uris))
173

174 175 176 177

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

		      (and glisp:*gdl-program-home*
			   (probe-file (merge-pathnames "static/"
							glisp:*gdl-program-home*)))
		      
189 190 191 192 193 194 195 196 197 198 199 200 201 202
		      (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)
203 204 205 206 207

  (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*))
208 209 210
  
  (setq *iid-random-state* (make-random-state t))
  
211 212
  (let (anything-changed?)
    (setq anything-changed? (glisp:set-settings *settings*))
213
    (start-gwl) 
214 215
    anything-changed?))

216 217


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

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


226
#-(and ccl windows-target)
227
(eval-when (:compile-toplevel :load-toplevel :execute)
228 229
  (defparameter *set-_?* nil)
  (defparameter *set-$?* nil)
230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252
  (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)
    (dotimes (n 3)
      (unless (typep millis '(unsigned-byte 32))
	(setq millis (/ millis 100))))
    
    (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)))))))

253
#-(and ccl windows-target)
254 255 256 257 258
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when *set-_?* (set-dispatch-macro-character #\# #\_ nil))
  (when *set-$?* (set-dispatch-macro-character #\# #\$ nil)))


259 260


261