Permalink
Browse files

Update web-server, new version of hunchentoot. Separate

out log-warn and log-error.  Change packaging to asdf2.
Change andes-path
  • Loading branch information...
bvds committed Mar 9, 2012
1 parent a1a292e commit c3c376d583bf72b732db32825a9e667982ee54c8
View
@@ -0,0 +1,40 @@
+;; Author(s):
+;; Brett van de Sande, March 2012
+;;; Copyright 2012 by Kurt Vanlehn and Brett van de Sande
+;;; This file is part of the Andes Intelligent Tutor Stystem.
+;;;
+;;; The Andes Intelligent Tutor System is free software: you can redistribute
+;;; it and/or modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation, either version 3
+;;; of the License, or (at your option) any later version.
+;;;
+;;; The Andes Solver 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 Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with the Andes Intelligent Tutor System. If not, see
+;;; <http:;;;www.gnu.org/licenses/>.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; ctl-c ctl-k compiles entire file
+
+;; The :text field is supposed to be plain text (rather than html).
+
+(in-package :cl-user)
+
+(defpackage :log-condition
+ (:use :cl)
+ (:export :log-error :log-warn :log-tag))
+
+(in-package :log-condition)
+
+(define-condition log-error (error)
+ ((tag :initarg :tag :reader log-tag)
+ (text :initarg :text :reader text))
+ (:report (lambda (c s) (write-string (text c) s))))
+
+(define-condition log-warn (warning)
+ ((tag :initarg :tag :reader log-tag)
+ (text :initarg :text :reader text))
+ (:report (lambda (c s) (write-string (text c) s))))
View
@@ -21,7 +21,7 @@
(in-package :cl-user)
(defpackage :webserver
- (:use :cl :hunchentoot :json)
+ (:use :cl :hunchentoot :json :log-condition)
(:export :defun-method :start-json-rpc-services :stop-json-rpc-services
:*stdout* :print-sessions :*env* :close-idle-sessions :*debug*
:*turn-timeout* :*time*
@@ -62,7 +62,7 @@
;; One could easily extend this to multiple web servers or multiple
;; services, but we don't need that now.
(when *server* (error "server already started"))
- (setf *dispatch-table* (list #'default-dispatcher))
+ (setf *dispatch-table* (list))
(dolist (service services)
(let ((logger (cadr (member :log-function (cdr service)))))
(push (create-prefix-dispatcher
@@ -82,15 +82,24 @@
;; Error handlers
(setf *http-error-handler* 'json-rpc-error-message)
- ;; Log any errors in Hunchentoot or not otherwise handled.
- ;; In particular, log any errors or warning using log-function
(when server-log-path (setf *MESSAGE-LOG-PATHNAME* server-log-path))
;; Test for multi-threading
(unless hunchentoot::*supports-threads-p*
(warn "Hunchentoot running without thread support, performance may be seriously degraded."))
- (setf *server* (start (make-instance 'acceptor :port port))))
+ (setf *server* (start
+ (make-instance
+ 'easy-acceptor
+ :port port
+ ;; access already logged by Apache
+ :ACCESS-LOG-DESTINATION nil
+ ;; Log any errors in Hunchentoot or
+ ;; not otherwise handled.
+ ;; In particular, log any errors or
+ ;; warning using log-function
+ :message-log-destination server-log-path
+ ))))
(defun json-rpc-error-message (err)
(format nil "{\"jsonrpc\": \"2.0\", \"error\": {\"code\": ~A, \"message\": \"Hunchentoot error: ~A\"}, \"id\": null}"
@@ -362,17 +371,6 @@
`(((:action . "show-hint")
(:text . ,(format nil "An error occurred:<br>~%~A~%" condition)))))
-;; The :text field is supposed to be plain text (rather than html).
-(define-condition log-error (error)
- ((tag :initarg :tag :reader log-tag)
- (text :initarg :text :reader text))
- (:report (lambda (c s) (write-string (text c) s))))
-
-(define-condition log-warn (warning)
- ((tag :initarg :tag :reader log-tag)
- (text :initarg :text :reader text))
- (:report (lambda (c s) (write-string (text c) s))))
-
(defun log-err (condition)
"Log after an error or warning has occurred."
(let ((result '((:log . "server") (:action . "log"))))
View
@@ -421,14 +421,14 @@
(open-review-window-html
(or (exptype-short-name qexp)
(progn
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'exptype-no-short-name (exptype-type qexp))
:text "ExpType missing short-name.")
(string-downcase (string (exptype-type qexp)))))
"quantities.html"
:section (string (exptype-type qexp))
:title "Quantities" :value (exptype-type qexp)))
- (t (warn 'webserver:log-warn
+ (t (warn 'log-condition:log-warn
:tag (list 'exptype-non-quantity (exptype-type qexp))
:text "Exptype is not a quantity.")
(string-downcase (string (exptype-type qexp))))))
@@ -619,7 +619,7 @@
"Pull the quantity phrase out of a definition: should match variablename.js"
(when (> (length symbol) 0) ;variablename.js returns empty string on no match
(if (not (search symbol text :test test))
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'symbol-definition-mismatch symbol text)
:text "Symbol does not match definition.")
;; Find first occurence of symbol in text and take rest of text.
@@ -1501,7 +1501,7 @@
;; StudentEntry-ErrInterp should have been set before
;; calling this function, perhaps by a call to (diagnose entry).
;; Otherwise, this means that the grading has not been done.
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'undiagnosed-entry (StudentEntry-prop entry))
:text "Undiagnosed error for studententry."))
(diagnose entry))
@@ -1637,19 +1637,19 @@
:key #'enode-entries)))
(cond
((null sysent)
- (error 'webserver:log-error
+ (error 'log-condition:log-error
:tag (list 'done-button-without-systementry id)
:text "No SystemEntry for button"))
((null PSM)
- (error 'webserver:log-error
+ (error 'log-condition:log-error
:tag (list 'done-button-without-enode id)
:text "No problem step found for button"))
;; If this is not a non-quant psm then we also need to throw an error
;; asserting that fact.
((not (enode-has-mark? PSM 'non-quant))
- (error 'webserver:log-error
+ (error 'log-condition:log-error
:tag (list 'bad-mark-for-button-enode psm id)
:text "Unmarked enode matching non-quant IDNum"))
@@ -1737,7 +1737,7 @@
(setf (turn-id rem) (StudentEntry-id entry))
rem))
- (t (warn 'webserver:log-warn
+ (t (warn 'log-condition:log-warn
:tag (list 'make-tutor-response-bad-arg state spontaneous)
:text "unsupported state"))))
@@ -1751,7 +1751,7 @@
(make-incorrect-reply entry (ErrorInterp-remediation
(StudentEntry-ErrInterp entry)))
(progn
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'reply-missing-rem error-tag
(when (StudentEntry-ErrInterp entry) t)
(studentEntry-prop entry))
View
@@ -158,7 +158,7 @@
;; Often occurs when rerunning logs through help
;; server and hint sequence has changed.
;; Bug #1947
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'iea-check-response response)
:text "iea-check-response expecting cons")
(return-from iea-check-response))
@@ -266,7 +266,7 @@
(cond ((eql Response 'yes)
(iea-prompt-alt-axes-yes Equation Bindings NewAxis))
((eql Response 'no) (iea-prompt-alt-axes-no))
- (t (warn 'webserver:log-warn
+ (t (warn 'log-condition:log-warn
:tag (list 'iea-alternate-axes-prompt
response)
:text "invalid response"))))
View
@@ -134,12 +134,14 @@
(answer-only-dispatcher Command Arguments)
(apply command Arguments)))
(Str (cond ((turn-p Result) (return-turn time Result))
- ((listp Result) result)
- (t (warn "Invalid result format ~A" result)))))
-
+ ((every #'alistp result) result)
+ (t (warn 'log-condition:log-warn
+ :tag (list 'invalid-turn-result-format result)
+ :text "Invalid result format.")))))
+
;; Having nil violates the API
(when (and (turn-p result) (member nil (turn-result result)))
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'result-contains-nil command (turn-result result))
:text "nil in solution-step reply"))
@@ -163,12 +165,12 @@
(score-hint-request (turn-assoc result)
*help-last-entries*))
- ;; Irrespective of the entry we need to inform the workbench of
+ ;; Irrespective of the entry, we need to inform the workbench of
;; the current total score if it has changed since last sent
(let ((current-score (calculate-score)))
(cond
((null current-score)
- (warn 'webserver:log-warn :tag (list 'null-grading-score)
+ (warn 'log-condition:log-warn :tag (list 'null-grading-score)
:text "null grading score"))
((or (null *last-score*)
(> (abs (- current-score *last-score*)) 0.01))
@@ -279,7 +281,7 @@
;; been logged. Bug #1935
(when (and (notany #'student-log-line result)
(not **checking-entries**))
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'incorrect-missing-interp id)
:text "Red turn without logging interp."))
(push `((:action . "modify-object") (:id . ,id)
View
@@ -1037,7 +1037,7 @@
((nsh-start-principle-free?) (nsh-start-principle-free))
;; At this point we know that an error has occured so we
;; need to signal that to the system for later use.
- (t (warn 'webserver:log-warn
+ (t (warn 'log-condition:log-warn
:tag (list 'nsh-prompt-start-invalid (problem-name *cp*)
*nsh-problem-type*)
:text "Invalid problem setup supplied."))))
@@ -1572,7 +1572,7 @@
(unless (stringp response)
(unless (eql response 'explain-more)
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'nsh-check-sought-resp response)
:text "unexpected value"))
(return-from nsh-check-sought-resp
@@ -1651,7 +1651,7 @@
;; Find matching qnode.
(let ((q (match-exp->qnode prop (problem-graph *cp*))))
(unless q
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'unique-prop-response-no-qnode prop)
:text "no qnode match"))
(nsh-ask-first-principle (random-positive-feedback) q)))))
@@ -1690,7 +1690,7 @@
(qexp (lookup-expression-struct sought)))
(if (exptype-p qexp)
(quantity-html-link qexp)
- (progn (warn 'webserver:log-warn
+ (progn (warn 'log-condition:log-warn
:tag (list 'return-answer-quantity-short-english sought)
:text "no ontology match")
(def-np sought)))))
@@ -1704,7 +1704,7 @@
(solution-quantities
(delete-if #'(lambda (p)
(unless (exptype-p p)
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'nsh-sought-resp-ambiguous p)
:text "No ontology match")
t))
@@ -1994,7 +1994,7 @@
;;; now, review/principles.json must be generated by hand from KB.
(defun nsh-cfp-principle-null (value Sought past)
"Account for an unknown psm name or bad object."
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'nsh-invalid-principle value)
:text "invalid response from picking principle")
(nsh-wrong-fp-resp
@@ -2294,7 +2294,7 @@
(nsh-cfp-choose-best-fp
(nsh-cfp-collect-valid-fps Choices Sought)
Sought Past))
- (t (warn 'webserver:log-warn
+ (t (warn 'log-condition:log-warn
:tag (list 'nsh-cfp-prompt-change-axis
response)
:text "bad response")
@@ -2392,7 +2392,7 @@
((eql Response 'principle)
(nsh-wrong-fp-resp "" Sought Past
:case 'cbf-invalid-no))
- (t (warn 'webserver:log-warn
+ (t (warn 'log-condition:log-warn
:tag (list 'nsh-cbf-invalid response)
:text "bad response"))))
:Assoc '((nsh . cbf-invalid))))
@@ -2471,7 +2471,7 @@
;; the appropriate axes.
(nsh-cbf-invalid-axis Best Solutions Principles
Sought Past))
- (t (warn 'webserver:log-warn
+ (t (warn 'log-condition:log-warn
:tag (list 'nsh-cbf-invalid-different Response)
:text "invalid response"))))
:Assoc `((nsh cbf-invalid-different ,New ,Prompt))))
View
@@ -368,7 +368,7 @@
"Given a help entry prop generate the system entry for it and return."
;; include helpful message for this error:
(when (not (get-operator-by-tag (csdo-op Do)))
- (error 'webserver:log-error
+ (error 'log-condition:log-error
:tag (list 'operator-not-in-problem-file (csdo-op Do))
:text (strcat "Operator not found in current KB. "
View
@@ -119,7 +119,7 @@
;; Raising an error, rather than a warning, keeps subsequent
;; code in open-problem from being executed and sends a
;; message to the student.
- (error 'webserver:log-error :tag 'problem-load-failed
+ (error 'log-condition:log-error :tag 'problem-load-failed
:text (strcat "Unable to load problem " (string name)
". Please try another problem." ))))
View
@@ -221,7 +221,7 @@ list of characters and replacement strings."
(format nil "REPLACE INTO PROBLEM_ATTEMPT (clientID,userName,userproblem,userSection~:[~;,extra~]) values ('~a','~a','~A','~A'~@[,'~A'~])"
extra client-id student problem section extra))
(when (> (get-affected-rows *connection*) 1)
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'duplicate-client-id
client-id student
problem section extra)
@@ -236,7 +236,7 @@ list of characters and replacement strings."
"Intercept any errors, turning them into warnings, then return."
;; If there are json errors, we want to log them and then soldier on.
`(handler-case (progn ,@forms)
- (error (c) (warn 'webserver:log-warn
+ (error (c) (warn 'log-condition:log-warn
:tag (list 'database-error (type-of c)
;; The objects are generally strings and the
;; most errors occur for very long strings.
@@ -449,7 +449,7 @@ list of characters and replacement strings."
(truncate-client-id client-id)))))
(if (and (consp result) (consp (car result)))
(car (car result))
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'get-start-tID result
*old-client-id*
webserver:*log-id*
@@ -562,7 +562,7 @@ otherwise, use latest step tID. No-store means add to cache only."
;; The correct way for setting up section defaults is by using nil for student.
(when (and (stringp student)
(equal (string-right-trim match:*whitespace* student) ""))
- (error 'webserver:log-error :tag 'empty-student-string
+ (error 'log-condition:log-error :tag 'empty-student-string
:text "Null string sent for student"))
;; Save in cache, by either updating or pushing
View
@@ -29,7 +29,7 @@
(setf *fades*
(loop for fade in (problem-fade problem)
unless (car fade) do
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'fade-null-prop fade)
:text "Fade with null prop on load.")
else collect
@@ -43,7 +43,7 @@
(match-exp->qnode (second (car fade))
(problem-graph *cp*))
(car fade))
- (warn 'webserver:log-warn
+ (warn 'log-condition:log-warn
:tag (list 'invalid-fade-proposition (car fade))
:text "No systementry or bgnode match for fade."))
;; Evaluate the hints.
Oops, something went wrong.

0 comments on commit c3c376d

Please sign in to comment.