Commit 9aabcafb authored by Dave Cooper's avatar Dave Cooper

added deferred aserve publishing via publish-uris

parent f4a65138
......@@ -69,7 +69,6 @@ o allow input of required input-slots.
(the root-object update!)
(mapsend (list (the tree) (the inspector) (the viewport)) :update!)))
#+nil
(tatu-update-function
#'(lambda()
(the (set-slot! :root-object (the root-object)))
......
......@@ -23,13 +23,17 @@
(in-package :tasty)
(let ((tutorial-file
(or (probe-file (merge-pathnames "../doc/tutorial.pdf" (glisp:executable-homedir-pathname)))
(probe-file (merge-pathnames "gendl/documenation/tutorial/pdf/tutorial.pdf" glisp:*genworks-source-home*))
(warn "tutorial.pdf not found in distribution doc/ directory or source documentation directory for
(defun publish-tutorial (server)
(let ((tutorial-file
(or (probe-file (merge-pathnames "../doc/tutorial.pdf" (glisp:executable-homedir-pathname)))
(probe-file (merge-pathnames "gendl/documenation/tutorial/pdf/tutorial.pdf" glisp:*genworks-source-home*))
(warn "tutorial.pdf not found in distribution doc/ directory or source documentation directory for
publishing in tasty Help menu.~%"))))
(when tutorial-file (publish-file :path "/tutorial.pdf"
:file (namestring (truename tutorial-file)))))
(when tutorial-file (publish-file :path "/tutorial.pdf"
:server server
:file (namestring (truename tutorial-file))))))
(pushnew 'publish-tutorial *publishers*)
(define-object menu-section (sheet-section)
......
......@@ -22,6 +22,9 @@
(in-package :tasty)
(publish-gwl-app "/tasty" "tasty:assembly" :make-object-args (list :title "Genworks tasty"))
(defun publish-tasty (server)
(publish-gwl-app "/tasty" "tasty:assembly" :make-object-args (list :title "Genworks tasty") :server server))
(pushnew 'publish-tasty *publishers*)
......@@ -521,47 +521,48 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
(let ((image-file (the image-file)) (image-format :png)
(pdf-file (merge-pathnames "example.pdf" (glisp:temporary-folder)))
(url (the image-url)) (lisp-file (the lisp-file)))
(publish :path url
:content-type "image/png"
:format :binary
:function #'(lambda(req ent)
(format t "~&~%Loading example code and generating example image for ~s...~%"
(the part-full-symbol))
(the load-example)
(let ((command (format nil "\"~a\" -q -sDEVICE=~a \"-sOutputFile=~a\" -dTextAlphaBits=~a -dGraphicsAlphaBits=~a -dSAFER -dBATCH -dNOPAUSE \"~a\""
*gs-path* (ecase image-format
(:png "png16m")
(:gif "gif")
((:jpg :jpeg) "jpeg"))
image-file
*gs-text-alpha-bits*
*gs-graphics-alpha-bits*
pdf-file)))
(with-all-servers (server)
(publish :path url
:server server
:content-type "image/png"
:format :binary
:function #'(lambda(req ent)
(format t "~&~%Loading example code and generating example image for ~s...~%"
(the part-full-symbol))
(the load-example)
(let ((command (format nil "\"~a\" -q -sDEVICE=~a \"-sOutputFile=~a\" -dTextAlphaBits=~a -dGraphicsAlphaBits=~a -dSAFER -dBATCH -dNOPAUSE \"~a\""
*gs-path* (ecase image-format
(:png "png16m")
(:gif "gif")
((:jpg :jpeg) "jpeg"))
image-file
*gs-text-alpha-bits*
*gs-graphics-alpha-bits*
pdf-file)))
(let ((return-value
(glisp:run-program command :show-window? nil)))
(with-http-response (req ent)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent)
(let
((reply-stream (request-reply-stream req)))
(with-open-file
(image-stream image-file :element-type '(unsigned-byte 8))
(do ((val (read-byte image-stream nil nil)
(read-byte image-stream nil nil)))
((null val))
(write-byte val reply-stream))))))
(let ((return-value
(glisp:run-program command :show-window? nil)))
(with-http-response (req ent)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent)
(let
((reply-stream (request-reply-stream req)))
(with-open-file
(image-stream image-file :element-type '(unsigned-byte 8))
(do ((val (read-byte image-stream nil nil)
(read-byte image-stream nil nil)))
((null val))
(write-byte val reply-stream))))))
(when (or (null return-value) (zerop return-value))
(delete-file pdf-file)
(delete-file image-file)
(delete-file lisp-file)
(delete-file (make-pathname :name (pathname-name lisp-file)
:type glisp:*fasl-extension*
:directory (pathname-directory lisp-file)
:device (pathname-device lisp-file))))))))
(when (or (null return-value) (zerop return-value))
(delete-file pdf-file)
(delete-file image-file)
(delete-file lisp-file)
(delete-file (make-pathname :name (pathname-name lisp-file)
:type glisp:*fasl-extension*
:directory (pathname-directory lisp-file)
:device (pathname-device lisp-file)))))))))
(push url (gethash (make-keyword (the instance-id)) gwl::*url-hash-table*))
......
......@@ -21,10 +21,14 @@
(in-package :yadd)
(publish-shared :path "/yadd-lookup"
:object-type 'yadd::all)
(with-all-servers (server)
(defun publish-yadd (server)
(publish-shared :path "/yadd-lookup"
:server server
:object-type 'yadd::all)
(publish :path "/user-yadd"
:server server
:function #'(lambda(req ent)
......@@ -37,3 +41,5 @@
:server server
:function #'(lambda(req ent)
(gwl-make-part req ent "yadd:package-dokumentation"))))
(pushnew 'publish-yadd *publishers*)
......@@ -186,6 +186,7 @@ If you are interested in this effort we would love to hear from you at open-sour
#:iso-8601-date
#:universal-time-from-iso-8601
#:universal-time-to-plist
#:keywordize-plist
#:lastcar
#:least
#:let-streams
......@@ -928,6 +929,8 @@ If you are interested in this effort we would love to hear from you at open-sour
#:with-html-form
#:publish-shared
#:*publishers*
#:publish-uris
#:with-all-servers
#:web-drawing
......
......@@ -455,3 +455,11 @@ or <tt>~/genworks/gendl/emacs/glime.lisp</tt>.
(if (probe-file glime-source)
(load (compile-file glime-source :output-file (make-pathname :defaults (glisp:temporary-file) :type glisp:*fasl-extension*)))
(warn "Glime source not found at ~s.~%" glime-source))))
(defun keywordize-plist (plist)
(mapcan #'(lambda (key val)
(list (make-keyword key)
(if (atom val) val (keywordize-plist val))))
(plist-keys plist) (plist-values plist)))
......@@ -161,11 +161,20 @@
:js-to-eval-previi js-to-eval-previi))))
(defun publish-gdlajax (server)
(publish :path "/gdlAjax" :function 'gdlAjax :server server))
(pushnew 'publish-gdlajax *publishers*)
#+nil
(defun publish-gdlajax ()
(with-all-servers (server)
(publish :path "/gdlAjax" :function 'gdlAjax :server server)))
(publish-gdlajax)
;;(publish-gdlajax)
;;
;; FLAG -- remove this defunct version.
......
......@@ -46,7 +46,8 @@
(glisp:gc-full))))))
(with-all-servers (server)
(defun publish-make-and-answer (server)
(publish :path "/make"
:server server
:content-type "text/html"
......@@ -57,6 +58,8 @@
:content-type "text/html"
:function 'answer))
(pushnew 'publish-make-and-answer *publishers*)
(defun publish-fixed-prefix (fixed-prefix)
(with-all-servers (server)
(publish :path (string-append "/" fixed-prefix "/make")
......
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:gwl :description
"The Gendl\" Generative Web Language (GWL)" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20160828" :depends-on
(:bordeaux-threads :glisp :aserve :yason)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/defparameters")
(:file "source/presets") (:file "source/base-html-sheet")
(:file "source/base-html-utils") (:file "source/macros")
(:file "source/ignore-errors-with-backtrace")
(:file "source/utilities") (:file "source/answer")
(:file "source/accessories") (:file "source/gdl-remote")
(:file "source/vanilla-remote") (:file "source/base64-utils")
(:file "source/cl-pdf-patches") (:file "source/color-palette")
(:file "source/crawler") (:file "source/log-utils")
(:file "source/new-urls") (:file "source/publish")
(:file "source/remote-object")
(:file "source/security-check-failed")
(:file "form-elements/source/grid-form-element")
(:file "form-elements/source/macros")
(:file "form-elements/source/primitives")
(:file "ajax/source/parameters") (:file "ajax/source/ajax")
(:file "ajax/source/base-ajax-sheet")
(:file "ajax/source/skeleton-ui-element")
(:file "gwl-session/source/parameters")
(:file "gwl-session/source/cleanup")
(:file "gwl-session/source/functions")
(:file "gwl-session/source/session-control-auto-refresh")
(:file "gwl-session/source/session-control-mixin")
(:file "gwl-session/source/session-recovery")
(:file "gwl-session/source/session-report")
(:file "js-libs/jquery/source/package")
(:file "js-libs/jquery/source/slider-form-control")
(:file "zzinit/source/initialize") (:file "zzinit/source/zzinit")))
;;;; -*- coding: utf-8 -*-
(asdf:defsystem #:gwl :description
"The Gendl® Generative Web Language (GWL)" :author "John McCarthy"
:license "Affero Gnu Public License (http://www.gnu.org/licenses/)"
:serial t :version "20161025" :depends-on
(:bordeaux-threads :glisp :aserve :yason)
#-asdf-unicode :defsystem-depends-on #-asdf-unicode (:asdf-encodings)
#+asdf-encodings :encoding #+asdf-encodings :utf-8
:components
((:file "source/package") (:file "source/with-all-servers")
(:file "source/defparameters") (:file "source/base-html-sheet")
(:file "source/html-format") (:file "source/macros")
(:file "source/presets") (:file "source/base-html-utils")
(:file "source/ignore-errors-with-backtrace")
(:file "source/utilities") (:file "source/answer")
(:file "source/accessories") (:file "source/gdl-remote")
(:file "source/vanilla-remote") (:file "source/base64-utils")
(:file "source/cl-pdf-patches") (:file "source/color-palette")
(:file "source/crawler") (:file "source/log-utils")
(:file "source/new-urls") (:file "source/publish")
(:file "source/remote-object")
(:file "source/security-check-failed")
(:file "form-elements/source/grid-form-element")
(:file "form-elements/source/macros")
(:file "form-elements/source/primitives")
(:file "ajax/source/parameters") (:file "ajax/source/ajax")
(:file "ajax/source/base-ajax-sheet")
(:file "ajax/source/skeleton-ui-element")
(:file "gwl-session/source/parameters")
(:file "gwl-session/source/cleanup")
(:file "gwl-session/source/functions")
(:file "gwl-session/source/session-control-auto-refresh")
(:file "gwl-session/source/session-control-mixin")
(:file "gwl-session/source/session-recovery")
(:file "gwl-session/source/session-report")
(:file "js-libs/jquery/source/package")
(:file "js-libs/jquery/source/slider-form-control")
(:file "zzinit/source/initialize") (:file "zzinit/source/zzinit")))
......@@ -174,17 +174,21 @@ the browser in development mode). Defaults to NIL (the empty list)."
(if (the plain-url?) (format nil "/~a" (the (compute-url)))
(format nil "~a/sessions/~a/~a" (if (the fixed-url-prefix) (format nil "/~a" (the fixed-url-prefix)) "")
(the :instance-id) (the (compute-url))))))
(publish
:path url
:content-type "text/html; charset=UTF-8"
:host (the host)
:function #'(lambda (req ent)
(the before-response!)
(present-part req ent url :instance-id (when (the plain-url?)
(the instance-id))
:header-plist (the header-plist)
:fixed-prefix (the fixed-url-prefix))))
(with-all-servers (server)
(publish
:path url
:server server
:content-type "text/html; charset=UTF-8"
:host (the host)
:function #'(lambda (req ent)
(the before-response!)
(present-part req ent url :instance-id (when (the plain-url?)
(the instance-id))
:header-plist (the header-plist)
:fixed-prefix (the fixed-url-prefix)))))
(pushnew url (gethash (make-keyword (the instance-id)) *url-hash-table*) :test #'string-equal)
(when (the fixed-url-prefix) (publish-fixed-prefix (the fixed-url-prefix)))
(setf (gethash url *descriptive-url-hash*) (the root-path))
(when *debug?* (print-variables url))
......
This diff is collapsed.
......@@ -22,15 +22,8 @@
(in-package :gwl)
(publish :path "/color-map"
:function #'(lambda(req ent)
(gwl-make-part req ent "gwl-user::color-map")))
(publish :path "/color-palette"
:function #'(lambda(req ent)
(gwl-make-part req ent "gwl-user::color-map")))
(define-object color-map (base-html-sheet)
:documentation
......@@ -49,3 +42,18 @@
(format *html-stream* "~{~a~^, ~}"
(gethash key *color-table-decimal*))))))
*color-table*)))))))
(defun publish-color-map (server)
(publish :path "/color-map"
:server server
:function #'(lambda(req ent)
(gwl-make-part req ent 'color-map)))
(publish :path "/color-palette"
:server server
:function #'(lambda(req ent)
(gwl-make-part req ent 'color-map))))
(pushnew 'publish-color-map *publishers*)
......@@ -178,17 +178,19 @@ the browser in development mode). Defaults to NIL (the empty list)."
(format nil "~a/sessions/~a/~a" (if (the fixed-url-prefix)
(format nil "/~a" (the fixed-url-prefix)) "")
(the :instance-id) (the (compute-url))))))
(publish
:path url
:content-type "text/html"
:host (the host)
:function #'(lambda (req ent)
(the before-response!)
(present-part req ent url :instance-id (when (and (the plain-url?)
(not (the use-cookie?)))
(the instance-id))
:header-plist (the header-plist)
:fixed-prefix (the fixed-url-prefix))))
(with-all-servers (server)
(publish
:path url
:server server
:content-type "text/html"
:host (the host)
:function #'(lambda (req ent)
(the before-response!)
(present-part req ent url :instance-id (when (and (the plain-url?)
(not (the use-cookie?)))
(the instance-id))
:header-plist (the header-plist)
:fixed-prefix (the fixed-url-prefix)))))
(unless (the use-cookie?)
(pushnew url (gethash (make-keyword (the instance-id)) *url-hash-table*) :test #'string-equal))
......
......@@ -133,3 +133,7 @@ Defaults to t.")
(defparameter *recovery-url-default* "/" "The url that the session-control-mixin will use for the recovery url")
(defparameter *publishers* nil "List of functions which accept server argument to do any aserve publishings.")
(defun publish-uris ()
(with-all-servers (server) (dolist (publisher (reverse *publishers*)) (funcall publisher server))))
......@@ -19,9 +19,8 @@
;; <http://www.gnu.org/licenses/>.
;;
("package" "defparameters" "presets"
"base-html-sheet" "base-html-utils"
"macros" "ignore-errors-with-backtrace" "initialize" "utilities" "answer"
"accessories" "layout-mixin"
("package" "with-all-servers" "defparameters" "base-html-sheet" "html-format"
"macros" "presets" "base-html-utils" "ignore-errors-with-backtrace"
"initialize" "utilities" "answer" "accessories" "layout-mixin"
"application-mixin" "gdl-remote" "vanilla-remote")
This diff is collapsed.
......@@ -22,11 +22,7 @@
(in-package :gwl)
(defmacro with-all-servers ((server) &rest body)
(let ((server-var (gensym)))
`(dolist (,server-var (list *wserver* *ssl-server*))
(when ,server-var
(let ((,server ,server-var)) ,@body)))))
(define-object form-mixin ())
......@@ -69,7 +65,8 @@
(:p ((:input :type :submit :name :subbmit :value " OK ")))))
(defmacro with-html-form ((&key name multipart? enctype target requestor on-submit suppress-border? local-anchor cl-who?)
(defmacro with-html-form ((&key name id multipart? enctype target requestor on-submit suppress-border? local-anchor cl-who?)
&body body)
"Enclose a body of code with a form.
......@@ -82,14 +79,15 @@ FLAG -- fill in.
(let ((%enctype% (gensym))
(fixed-prefix (gensym)))
`(let ((,%enctype% (cond (,enctype ,enctype) (,multipart? "multipart/form-data")))
(,fixed-prefix (the fixed-url-prefix)))
(,fixed-prefix (let ((prefix (the fixed-url-prefix)))
(when prefix (string-append "/" prefix)))))
(,@(if cl-who? '(with-html-output (*stream* nil :indent t))
'(html
;;html-stream *stream*
))
((:form :method :|post|
:id ,id
:action (string-append (or ,fixed-prefix "")
(format nil (if ,local-anchor (format nil "/answer#~a" ,local-anchor) "/answer")))
......
This diff is collapsed.
;;
;; Copyright 2016 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)
(defmacro with-all-servers ((server) &rest body)
(let ((server-var (gensym)))
`(dolist (,server-var (list *wserver* *ssl-server*))
(when ,server-var
(let ((,server ,server-var)) ,@body)))))
......@@ -28,26 +28,27 @@
(or (probe-file pathname)
(warn "Required static subdirectory ~a does not appear to exist.~%" pathname))))
(defun publish-images ()
(with-all-servers (server)
(publish-directory
:prefix "/images/gwl/"
:server server
:destination (namestring (ensure-static-relative-pathname "gwl/images/")))))
(defun publish-images (server)
(publish-directory
:prefix "/images/gwl/"
:server server
:destination (namestring (ensure-static-relative-pathname "gwl/images/"))))
(defun publish-statics ()
(with-all-servers (server)
(publish-directory
:prefix "/static/"
:server server
:destination (namestring (ensure-static-relative-pathname "")))))
(defun publish-statics (server)
(publish-directory
:prefix "/static/"
:server server
:destination (namestring (ensure-static-relative-pathname ""))))
(defun publish-style ()
(with-all-servers (server)
(publish-directory
:prefix "/style/"
:server server
:destination (namestring (ensure-static-relative-pathname "gwl/style/")))))
(defun publish-style (server)
(publish-directory
:prefix "/style/"
:server server
:destination (namestring (ensure-static-relative-pathname "gwl/style/"))))
(dolist (func (list 'publish-images 'publish-statics 'publish-style))
(pushnew func *publishers*))
(defvar *aserve-listeners* 25)
......@@ -68,7 +69,7 @@ Perhaps a zombie process is holding port ~a?~%" port port))
(defun start-gwl (&key (port *aserve-port*) (listeners *aserve-listeners*)
(external-format :utf8-base))
(net.aserve:shutdown :server net.aserve:*wserver*)
(let ((wait-time 1))
(let ((wait-time 1))
(block :outer
(do () (nil)
(let ((port port))
......@@ -79,12 +80,14 @@ Perhaps a zombie process is holding port ~a?~%" port port))
"~&Trying to start AllegroServe on ~a...~%") port)
(if (ignore-errors
(setq net.aserve:*wserver*
(net.aserve:start :port port :listeners listeners ;; :server :new
(net.aserve:start :port port :listeners listeners :server :new
#-mswindows :external-format #-mswindows external-format)))
(return-from :outer port)
(progn (sleep (random wait-time)) (return-from :inner))))
(incf port))))
(incf wait-time 0.1)))))
(incf wait-time 0.1))))
(publish-uris))
(defvar *settings*
......@@ -120,6 +123,6 @@ Perhaps a zombie process is holding port ~a?~%" port port))
(let (anything-changed?)
(setq anything-changed? (glisp:set-settings *settings*))
(publish-images) (publish-statics) (publish-style) (start-gwl)
(start-gwl)
anything-changed?))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment