Commit f9b9d1ce authored by Dave Cooper's avatar Dave Cooper
Browse files

added more stray patches.

parent a2a1e5b2
*~
bin/
\ No newline at end of file
bin/
system-index.txt
\ No newline at end of file
......@@ -21,6 +21,10 @@
(in-package :glisp)
;;
;; 4 forms below merged into devo 2020-08-17
;;
(defun getuid ()
#-(or allegro ccl) (error "need getuid impl.")
#+(or allegro ccl)
......@@ -37,6 +41,11 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export 'getuid :glisp) (export 'setuid :glisp) (export 'setgid :glisp))
;;
;; Merged into devo 2020-08-17
;;
#-(or allegro lispworks cmu sbcl ccl abcl ecl clasp clisp)
(error "Need implementation for executable-homedir-pathname for currently running lisp.~%")
(#+allegro
......@@ -58,5 +67,13 @@
(lisp-implementation-type))))
;;
;; Merged into devo 2020-08-17.
;;
(#+allegro
excl:without-package-locks #-allegro progn
(#+allegro
excl:without-redefinition-warnings #-allegro progn
(defun process-run-function (name-or-options preset-function &rest initial-bindings)
(bt:make-thread preset-function :name name-or-options :initial-bindings initial-bindings))))
......@@ -55,3 +55,213 @@
(eval-when (:compile-toplevel :load-toplevel :execute)
(export 'wmd :gwl))
;;
;; Merged into devo 2020-08-17
;;
(#+allegro
excl:without-package-locks
#-allegro
progn
(defun answer (req ent)
(let ((query (request-query req)))
(when *debug?* (format t "before multi-part processing, query is: ~s~%" query))
(when (null query) (setq query (process-multipart-submission req)))
(when gwl::*debug?* (print-variables query))
(let* ((requestor (query-arg-to-root-path query "requestor"))
(iid (make-keyword
(rest (assoc "iid" query :test #'string-equal))))
(hash-entry (gethash iid *instance-hash-table*))
;;
;; FLAG -- patch starts
;;
(root-object (or (first hash-entry)
(restore-from-snap iid)))
(skin (third hash-entry))
;;
;; FLAG -- patch ends
;;
(recovery-object? (typep root-object 'session-recovery))
(requestor (when (and root-object (not recovery-object?))
(the-object root-object
(follow-root-path requestor))))
(bashee (when requestor (the-object requestor bashee)))
(rest-plist (when (not recovery-object?)
(merge-plist-duplicates
(assoc-list-to-plist
(remove-if
#'(lambda(item)
(member (first item)
(list "requestor" "iid")
:test #'string-equal)) query)
:case-sensitive? t))))
(possible-nils (when (not recovery-object?)
(the-object requestor possible-nils)))
(rest-plist (when requestor
(append rest-plist
(mapcan #'(lambda(key) (list key nil))
(set-difference possible-nils
(plist-keys rest-plist))))))
(settables (when bashee (the-object bashee %settable-slots%)))
(rest-keys (plist-keys rest-plist))
(query-plist (mapcan #'(lambda(key) (list key (getf rest-plist key)))
(remove-if #'(lambda(key) (gethash (make-keyword-sensitive key) settables)) rest-keys))))
(let ((respondent (the-object requestor respondent)))
(the-object respondent root (set-remote-host! req))
(unless (the-object respondent root do-security-check)
(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 ((*req* req) (*ent* ent))
(the-object respondent root security-check-failed write-html-sheet))))
(return-from answer nil)))
(when gwl::*debug?* (print-variables query
requestor
iid
hash-entry
root-object
recovery-object?
requestor
bashee
rest-plist
possible-nils
settables
rest-keys
query-plist))
(let ((fe-processor (make-object 'form-element-processor
:bashee bashee
:query-plist query-plist)))
(cond (recovery-object? (with-http-response (req ent :response *response-moved-permanently*)
(setf (reply-header-slot-value req :location)
(defaulting (the-object root-object recovery-url) *failed-request-url*))
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(with-http-body (req ent))))
((null requestor) (net.aserve::failed-request req))
(t (let ((*query-plist* query-plist) (*field-plist* rest-plist))
(the-object requestor (before-set!)))
;;(when *debug?* (print-variables *query-plist* rest-plist rest-keys))
(when *debug?* (setq *f-e-p* fe-processor))
(dolist (key rest-keys)
(when (gethash (make-keyword-sensitive key) settables)
;;(when *debug?* (print-variables key))
(the-object bashee (set-slot-if-needed! (make-keyword-sensitive key) (getf rest-plist key)))))
(the-object fe-processor validate-and-set!)
(when
(and (fboundp 'process-graphics-fields)
(typep (the-object requestor) (read-from-string "gwl:base-html-graphics-sheet"))
(the-object requestor (evaluate :view-object)))
(setq query-plist (funcall (read-from-string "gwl::process-graphics-fields")
query query-plist root-object requestor)))
(when (not (equalp (the-object bashee query-plist) query-plist))
(the-object bashee
(set-slot! :query-plist query-plist
:remember? (not (member :query-plist
(the-object bashee transitory-slots))))))
(let ((result (let ((*req* req) (*ent* ent) (*skin* skin)
(*query* query)) (the-object requestor (after-set!)))))
(let ((respondent (if (and (consp result) (eql (first result) :go-to)) (second result)
(the-object requestor respondent))))
;;
;; Dashboard stuff
;;
;;
;; FLAG - use actual application-root rather than simple root.
;;
(when (typep root-object 'session-control-mixin) (the-object root-object (set-expires-at)))
(the-object respondent root (set-time-last-touched!))
(the-object respondent root (set-slot! :last-visited-root-path
(the-object respondent root-path)))
;;
;;
;;
(with-http-response (req ent :response *response-found*)
(setf (reply-header-slot-value req :cache-control) "no-cache")
(setf (reply-header-slot-value req :pragma) "no-cache")
(setf (reply-header-slot-value req :location) (the-object respondent url))
(let ((keys (plist-keys (the-object respondent header-plist)))
(values (plist-values (the-object respondent header-plist))))
(mapc #'(lambda(key val)
(setf (reply-header-slot-value req key) val)) keys values))
(with-http-body (req ent)
(let ((*req* req) (*ent* ent) (*skin* skin))
(multiple-value-bind (check error)
(when (the-object respondent check-sanity?)
(ignore-errors (the-object respondent check-sanity)))
(declare (ignore check))
(if error (the-object respondent (sanity-error error))))))))))))))))
;;
;; Merged into devo 2020-08-17.
;;
(#+allegro
excl:without-package-locks #-allegro progn
(#+allegro
excl:without-redefinition-warnings #-allegro progn
(defun start-session-reaper (&key (minutes 20) (debug? t) (listeners 20) extra-functions restart-server?)
(declare (ignore listeners))
(format t "~2%Lauching Expired Session Reaper to awaken and run every ~a minute~:p~2%" minutes)
(glisp:process-run-function
"GWL Session Reaper"
#'(lambda()
(do ()(nil) (sleep (* minutes 60))
(when debug? (format t "~&Reaper waking up...~%"))
(when *reap-expired-sessions?*
(maphash #'(lambda(key val) (declare (ignore key))
(when (typep (first val) 'session-control-mixin)
(the-object (first val) (clear-expired-session :debug? debug?))))
*instance-hash-table*))
(when restart-server?
(glisp:w-o-interrupts
(let ((port (server-port)))
(when (and port (>= port 1000))
(net.aserve:shutdown) (net.aserve:start :port port :listeners listeners)))))
(glisp:w-o-interrupts
(mapc #'funcall (ensure-list extra-functions)) (glisp:gc-full))))))))
;;
;; Merged into devo 2020-08-17.
;;
(#+allegro
excl:without-package-locks #-allegro progn
(#+allegro
excl:without-redefinition-warnings #-allegro progn
(define-object-amendment base-html-sheet ()
:input-slots ((instance-id nil :defaulting :settable)))))
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