Commit 98ed3335 authored by Dave Cooper's avatar Dave Cooper
Browse files

added wind demo and server log to server

parent ba318fad
......@@ -28,4 +28,4 @@
;; Initialize SMLib here if available.
;;
;;(smlib::initialize-smlib)
......@@ -8,7 +8,47 @@
((css-style "/css-demo-1/style-wind-1.css"))
:computed-slots
((additional-header-content
((use-raphael? t)
(iges-url (let ((url (format nil "~a/model.iges" (the url))))
(publish :path url
:function #'(lambda(req ent)
(with-http-response (req ent)
(with-http-body (req ent)
(with-format (iges (request-reply-stream req))
(write-the graphics rotor cad-output-tree))))))
url))
(step-url (let ((url (format nil "~a/model.step" (the url))))
(publish :path url
:function #'(lambda(req ent)
(with-http-response (req ent)
(with-http-body (req ent)
(with-format (step (request-reply-stream req))
(write-the graphics rotor cad-output-tree))))))
url))
(stl-url (let ((url (format nil "~a/model.stl" (the url))))
(publish :path url
:function #'(lambda(req ent)
(with-http-response (req ent)
(with-http-body (req ent)
(with-format (stl (request-reply-stream req))
(write-the graphics rotor cad-output-tree))))))
url))
(x3d-url (let ((url (format nil "~a/model.x3d" (the url))))
(publish :path url
:function #'(lambda(req ent)
(with-http-response (req ent)
(with-http-body (req ent)
(with-format (x3d (request-reply-stream req))
(write-the graphics rotor cad-output-tree))))))
url))
(additional-header-content
(with-cl-who-string ()
(:p (when *developing?* (str (the development-links))))
(:style :type "text/css" :media "all"
......@@ -69,7 +109,8 @@
((general-inputs :type 'general-inputs)
(displayed-component :type 'displayed-component)
(export-section :type 'export-section)
(export-section :type 'export-section
:pass-down (iges-url step-url stl-url x3d-url))
(turbine-characteristics-1 :type 'turbine-characteristics-1)
(turbine-characteristics-2 :type 'turbine-characteristics-2)
(graphics :type 'graphics
......@@ -124,6 +165,8 @@
(define-object export-section (sheet-section)
:input-slots (iges-url step-url stl-url x3d-url)
:computed-slots
((main-view (with-cl-who-string ()
......@@ -132,13 +175,31 @@
(:tr (:td) (:td))
(:tr
((:td) "IGES file")
((:td :align "right") (:button :onClick "www.ke-works.ro" (:i "Download"))))
(:tr
(:td "STL file")
((:td :align "right") (:button :onClick "www.ke-works.ro" (:i "Download"))))
(:tr
(:td "VRML file")
((:td :align "right") (:button :onClick "www.ke-works.ro" (:i "Download"))))
((:td :align "right")
((:a :href (the iges-url) :target "cad-data") "Flat"))
((:td :align "right")
((:span :title "coming soon...") "Assembly")))
(:tr
((:td) "STEP file")
((:td :align "right")
((:a :href (the step-url) :target "cad-data") "Flat"))
((:td :align "right")
((:span :title "coming soon...") "Assembly")))
(:tr
((:td) "STL file")
((:td :align "right")
((:a :href (the stl-url) :target "cad-data") "Flat"))
((:td :align "right")
((:span :title "coming soon...") "Assembly")))
(:tr
((:td) "X3D file")
((:td :align "right")
((:span :title "not available...") "Flat"))
((:td :align "right")
((:a :href (the x3d-url) :target "cad-data") "Assembly")))
#+nil
(:tr
(:td "PNG")
((:td :align "right") (:button :onClick "www.ke-works.ro" (:i "Download"))))))))))
......@@ -232,6 +293,8 @@
(inner-html (the graphics inner-html))
(js-to-eval (the graphics js-to-eval))
)
......@@ -240,10 +303,13 @@
:blade-concepts (the blade-concepts)
:nr-blades-data (the number-of-blades))
#+nil
(box :type 'surf::test-b-spline-surface
:sequence (:size 30))
(graphics :type 'base-ajax-graphics-sheet
:hidden? t
:respondent (the respondent)
:image-format-default :png
:view-direction-default :trimetric
:viewport-border-default 0
......@@ -299,3 +365,8 @@
(publish-directory :prefix "/css-demo-1"
:destination (format nil "~a" (merge-pathnames "css-demo-1" *data-pathname*)))
(defun init ()
(setq *data-pathname* "~dcooper8/genworks-gdl/demos/wind-demo-1/data/")
(publish-directory :prefix "/css-demo-1"
:destination (format nil "~a" (merge-pathnames "css-demo-1" *data-pathname*))))
\ No newline at end of file
......@@ -805,7 +805,7 @@ eshell."
(speedbar-highlight-face ((t (:background "sea green"))))
(font-lock-doc-string-face ((t (:foreground "Plum1" :bold t))))
(font-lock-exit-face ((t (:foreground "green"))))
(ff-paths-non-existant-file-face ((t (:foreground "NavyBlue" :bold t))))
;;(ff-paths-non-existant-file-face ((t (:foreground "NavyBlue" :bold t))))
(show-paren-match-face ((t (:background "red"))))
(show-paren-mismatch-face ((t (:foreground "white" :background "purple"))))
(message-header-to-face ((t (:foreground "green2" :bold t))))
......@@ -855,42 +855,42 @@ eshell."
(gnus-summary-low-read-face ((t (:foreground "PaleGreen" :italic t))))
(gnus-summary-normal-read-face ((t (:foreground "PaleGreen"))))
(gnus-splash-face ((t (:foreground "Brown"))))
(eshell-ls-directory-face ((t (:foreground "SkyBlue" :bold t))))
(eshell-ls-symlink-face ((t (:foreground "Cyan" :bold t))))
(eshell-ls-executable-face ((t (:foreground "Green" :bold t))))
(eshell-ls-readonly-face ((t (:foreground "Pink"))))
(eshell-ls-unreadable-face ((t (:foreground "DarkGrey"))))
(eshell-ls-special-face ((t (:foreground "Magenta" :bold t))))
(eshell-ls-missing-face ((t (:foreground "Red" :bold t))))
(eshell-ls-archive-face ((t (:foreground "Orchid" :bold t))))
(eshell-ls-backup-face ((t (:foreground "LightSalmon"))))
(eshell-ls-product-face ((t (:foreground "LightSalmon"))))
(eshell-ls-clutter-face ((t (:foreground "OrangeRed" :bold t))))
(eshell-prompt-face ((t (:foreground "Pink" :bold t))))
(term-default-fg ((t (nil))))
(term-default-bg ((t (nil))))
(term-default-fg-inv ((t (nil))))
(term-default-bg-inv ((t (nil))))
(term-bold ((t (:bold t))))
(term-underline ((t (:underline t))))
(term-invisible ((t (nil))))
(term-invisible-inv ((t (nil))))
(term-black ((t (:foreground "black"))))
(term-red ((t (:foreground "red"))))
(term-green ((t (:foreground "green"))))
(term-yellow ((t (:foreground "yellow"))))
(term-blue ((t (:foreground "blue"))))
(term-magenta ((t (:foreground "magenta"))))
(term-cyan ((t (:foreground "cyan"))))
(term-white ((t (:foreground "white"))))
(term-blackbg ((t (:background "black"))))
(term-redbg ((t (:background "red"))))
(term-greenbg ((t (:background "green"))))
(term-yellowbg ((t (:background "yellow"))))
(term-bluebg ((t (:background "blue"))))
(term-magentabg ((t (:background "magenta"))))
(term-cyanbg ((t (:background "cyan"))))
(term-whitebg ((t (:background "white"))))
;;(eshell-ls-directory-face ((t (:foreground "SkyBlue" :bold t))))
;;(eshell-ls-symlink-face ((t (:foreground "Cyan" :bold t))))
;;(eshell-ls-executable-face ((t (:foreground "Green" :bold t))))
;;(eshell-ls-readonly-face ((t (:foreground "Pink"))))
;;(eshell-ls-unreadable-face ((t (:foreground "DarkGrey"))))
;;(eshell-ls-special-face ((t (:foreground "Magenta" :bold t))))
;;(eshell-ls-missing-face ((t (:foreground "Red" :bold t))))
;;(eshell-ls-archive-face ((t (:foreground "Orchid" :bold t))))
;;(eshell-ls-backup-face ((t (:foreground "LightSalmon"))))
;;(eshell-ls-product-face ((t (:foreground "LightSalmon"))))
;;(eshell-ls-clutter-face ((t (:foreground "OrangeRed" :bold t))))
;;(eshell-prompt-face ((t (:foreground "Pink" :bold t))))
;;(term-default-fg ((t (nil))))
;;(term-default-bg ((t (nil))))
;;(term-default-fg-inv ((t (nil))))
;;(term-default-bg-inv ((t (nil))))
;;(term-bold ((t (:bold t))))
;;(term-underline ((t (:underline t))))
;;(term-invisible ((t (nil))))
;;(term-invisible-inv ((t (nil))))
;;(term-black ((t (:foreground "black"))))
;;(term-red ((t (:foreground "red"))))
;;(term-green ((t (:foreground "green"))))
;;(term-yellow ((t (:foreground "yellow"))))
;;(term-blue ((t (:foreground "blue"))))
;;(term-magenta ((t (:foreground "magenta"))))
;;(term-cyan ((t (:foreground "cyan"))))
;;(term-white ((t (:foreground "white"))))
;;(term-blackbg ((t (:background "black"))))
;;(term-redbg ((t (:background "red"))))
;;(term-greenbg ((t (:background "green"))))
;;(term-yellowbg ((t (:background "yellow"))))
;;(term-bluebg ((t (:background "blue"))))
;;(term-magentabg ((t (:background "magenta"))))
;;(term-cyanbg ((t (:background "cyan"))))
;;(term-whitebg ((t (:background "white"))))
(gnus-emphasis-bold ((t (:bold t))))
(gnus-emphasis-italic ((t (:italic t))))
(gnus-emphasis-underline ((t (:underline t))))
......
10
dir
990
svn://svn.genworks.com/rainforest/trunk/genworks/gdl/apps/server-log
svn://svn.genworks.com/rainforest
2010-09-29T18:40:16.637689Z
26
dcooper8
a8dd3158-16c2-4b09-9e8e-1a0d18a46f2f
source
dir
(:gdl-gwl)
\ No newline at end of file
(asdf:defsystem #:gdl-server-log :description
"Auto-generated asdf defsys from Genworks GDL cl-lite."
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :serial t
:version "2012091800" :depends-on (:gdl-gwl)
:components
((:lisp "source/package") (:lisp "source/assembly")
(:lisp "source/publish")))
\ No newline at end of file
10
dir
990
svn://svn.genworks.com/rainforest/trunk/genworks/gdl/apps/server-log/source
svn://svn.genworks.com/rainforest
2010-09-29T18:40:16.637689Z
26
dcooper8
a8dd3158-16c2-4b09-9e8e-1a0d18a46f2f
package.lisp
file
2011-11-01T23:13:23.459564Z
74b5a1f8a30d814211b9abe5aacf0381
2010-09-29T18:40:16.637689Z
26
dcooper8
has-props
127
file-ordering.isc
file
2011-11-01T23:13:23.459564Z
92d42a124ebbe036708c932bea978229
2010-09-29T18:40:16.637689Z
26
dcooper8
has-props
12
assembly.lisp
file
2011-11-01T23:13:23.459564Z
4c73645cc81572543732f636518487d3
2010-09-29T18:40:16.637689Z
26
dcooper8
has-props
3215
publish.lisp
file
2011-11-01T23:13:23.459564Z
345182a4bfb7efc8642df1c1037f5cb6
2010-09-29T18:40:16.637689Z
26
dcooper8
has-props
392
(in-package :aserve-log)
(define-object assembly (base-html-sheet)
:input-slots
((relevant-headings (list :domain :iso-time :uri-path :user-agent :referrer))
(relevant-hosts (list "www.genworks.com" "www.squeakymail.com")))
:functions
((write-html-sheet
()
(html
(:html
(:head (:title "Log Report"))
(:body (:center (:h2 "Log Report"))
(:p (the (:write-log-table)))))))
(:pass-filter?
(log &key relevant-hosts)
;;
;; FLAG -- make more general and configurable.
;;
(let ((domain (getf log :domain))
(uri-path (getf log :uri-path))
(user-agent (getf log :user-agent)))
(and (or (null relevant-hosts)
(member (getf log :uri-host) relevant-hosts :test #'string-equal))
(or (null user-agent)
(not (or (search "usabestnet" domain)
(search "c-68-40-98-13.hsd1.mi.comcast.net" domain)
(search "msnbot.msn.com" domain)
(search "netsonic.fi" domain)
(search "amiedu.fi" domain)
(search "looksmart" domain)
(search "buildrack" domain)
(search "wwnet.net" domain)
(search "internetseer.net" domain)
(search "googlebot.com" domain)
(search "inktomi" domain)
(search "echo.com" domain)
(search "netcraft.com" domain)
(search "spider" domain)
(string-equal uri-path "/robots.txt")
(string-equal uri-path "/server-log")
(search ".gif" uri-path)
(search ".jpg" uri-path)
(search "formmail" uri-path)
(string-equal user-agent "ia_archiver")
(search "Gozilla" user-agent)
(search "raw.no-ip.com/monitor" user-agent)
(search "grub" user-agent)
(search "Sleuth" user-agent)
(search "Ask Jeeves" user-agent)
(search "crawler" (string-downcase user-agent))
(search "robot" (string-downcase user-agent))
(search "LinkScan" user-agent)
(search "sitecheck.internetseer.com" user-agent)
(search "Googlebot" user-agent)))))))
(:write-log-table
()
(let* ((log-entries (progn (clear-log-buffer) *log-report-buffer*))
(latest-time (getf (first log-entries) :time))
(cut-off-time (- latest-time (* 5 24 60 60)))
(relevant-hosts (the :relevant-hosts))
(entry-hash (make-hash-table :size (length (the :relevant-headings)))))
(html
((:table :bgcolor :black :cellspacing 1 :cellpadding 2)
((:tr :bgcolor :yellow)
(dolist (heading (the :relevant-headings))
(html (:td (:princ (replace-substring (string-capitalize heading) "-" " "))))))
(dolist (log log-entries)
(when (and (> (getf log :time) cut-off-time)
(the (:pass-filter? log :relevant-hosts relevant-hosts)))
(html ((:tr :bgcolor (gethash :quartz *color-table*))
(dolist (heading (the :relevant-headings))
(let* ((value (getf log heading))
(hashed-value (gethash heading entry-hash)))
(if (not (equalp value hashed-value))
(progn (setf (gethash heading entry-hash) value)
(case heading
(:uri-path (html (:td ((:a :href (format nil "~(~a~)://~a~a"
(getf log :uri-scheme) (getf log :uri-host) value))
(:princ value)))))
(otherwise (html (:td (:princ value))))))
(html ((:td :bgcolor (gethash :aquamarine *color-table*)) :br)))))))))))))))
;; -*- mode: common-lisp; package: aserve-log -*-
(in-package :user)
(gwl:define-package :aserve-log (:export #:assembly))
(in-package :aserve-log)
(with-all-servers (server)
(publish :path "/iiug-log"
:server server
:function #'(lambda(req ent)
(gwl-make-part req ent "aserve-log:assembly"
:make-object-args (list :relevant-hosts (list "www.iiug.com")))))
(publish :path "/server-log"
:server server
:function #'(lambda(req ent)
(gwl-make-part req ent "aserve-log:assembly"))))
(in-package :aserve-log)
(define-object assembly (base-html-sheet)
:input-slots
((relevant-headings (list :domain :iso-time :uri-path :user-agent :referrer))
(relevant-hosts (list "www.genworks.com" "www.squeakymail.com")))
:functions
((write-html-sheet
()
(html
(:html
(:head (:title "Log Report"))
(:body (:center (:h2 "Log Report"))
(:p (the (:write-log-table)))))))
(:pass-filter?
(log &key relevant-hosts)
(declare (ignore log relevant-hosts))
t
;;
;; FLAG -- make more general and configurable.
;;
#+nil
(let ((domain (getf log :domain))
(uri-path (getf log :uri-path))
(user-agent (getf log :user-agent)))
(and (or (null relevant-hosts)
(member (getf log :uri-host) relevant-hosts :test #'string-equal))
(or (null user-agent)