Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

596 lines (519 sloc) 23.587 kB
;; Author(s):
;; Brett van de Sande, Nicholas Vaidyanathan
;;; Copyright 2009 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/>.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :cl-user)
(defpackage :andes-database
(:use :cl :json :mysql-connect)
(:export :write-transaction :destroy :create :set-session
:read-login-file
:get-matching-sessions :get-score
:old-sessions :set-old-session-start
:get-most-recent-tID
:get-state-property :get-state-properties
:set-state-property))
(in-package :andes-database)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Send to database
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *connection* nil "connection to db")
(defparameter *debug* nil "database debug")
(defvar *db-lock* #+sbcl (sb-thread:make-mutex)
#+(and (not sbcl) bordeaux-threads) (bordeaux-threads:make-lock))
;; Should be "defconstant"
(defparameter *skip-db* nil "don't actually use db")
;; We previously used mysql for database connections. However,
;; libmysql installs its own signal handler for SIGALRM, erasing the
;; sbcl signal handler. This prevents us from timing out hung session turns.
;; MySql drops connections that have been idle for over 8 hours.
;; We use idle-cleanup-function to periodically send a trivial query.
;; Instead, it may be better to catch the associated error,
;; and attempt to reconnect to the database.
;; A dropped connection can be simulated by logging into MySql, and using
;; SHOW PROCESSLIST; and KILL <Id>; to drop a connection.
(defmacro with-db (&body body)
"Excecute body with db mutex."
`(unless *skip-db*
(if *connection*
(sb-thread:with-mutex (*db-lock*) ,@body)
(error "No common database defined, can't continue."))))
(defun read-login-file (&optional path)
"Read the database login file; file contains user name, password & (optional) database name."
(with-open-file (f (or path (merge-pathnames "db_user_password"
cl-user::*andes-path*))
:if-does-not-exist nil)
(when f (values (read-line f) (read-line f) (read-line f nil)))))
(defun create (&key user password db host)
(multiple-value-bind (u p d) (read-login-file)
(setf user (or user u "root"))
(setf password (or password p (error "No database password given.")))
(setf db (or db d "andes3")))
(unless *skip-db*
(setf *connection*
(connect :host host :user user :password password :database db))))
(defun destroy ()
(unless *skip-db*
(disconnect *connection*)))
(defun write-transaction (client-id input reply)
"Record raw transaction in database."
(test-safe-string client-id)
(with-db
;; Test that PROBLEM_ATTEMPT entry already exits or create an empty one
;; Generally, this will only happen if open-problem has not been called
;; or has failed.
(unless
(query *connection*
(format nil
"SELECT clientID FROM PROBLEM_ATTEMPT WHERE clientID = '~A'"
(truncate-client-id client-id))
;;:field-names nil :flatp t :result-types :auto
)
(query *connection*
(format nil
"INSERT into PROBLEM_ATTEMPT (clientID) values ('~A')"
client-id)))
;; If an input or reply contains no json then it is a lisp nil and
;; sql null is inserted into database.
(query *connection*
(format nil "INSERT into STEP_TRANSACTION (clientID,client,server) values ('~A',~:[null~;~:*'~A'~],~:[null~;~:*'~A'~])"
client-id (make-safe-string input)
(make-safe-string reply)))
;; Add any model updates associated with the step.
(when webserver:*log-variable*
;; We consolidate turn updates (only log one per session)
;; to minimize size of STUDENT_STATE table.
(let ((tID (get-start-tID client-id)))
(if tID
;; Do oldest ones first.
(dolist (update (reverse webserver:*log-variable*))
(query *connection*
(format nil update tID)))
(warn "No tID found for session ~A" client-id))))))
;; Alist of sql control characters and replacement strings
(#-sbcl defconstant #+sbcl sb-int:defconstant-eqx
+sql-control-characters+ '((#\' . "''") (#\\ . "\\\\"))
#+sbcl #'equalp)
;; Test for any sql control characters.
;; This test can be used to detect an sql injection attack.
(defun test-safe-string (&rest strs)
(dolist (s strs)
(when s
(unless (loop for c across s
never (assoc c +sql-control-characters+ :test #'char=))
(error "Invalid character in ~S" s)))))
;; Escaping ' via '' follows ANSI SQL standard.
;; If the Database escapes backslashes, must also do those.
;; In mysql, NO_BACKSLASH_ESCAPES is not set, by default.
;; See http://lists.b9.com/pipermail/clsql-help/2005-July/000456.html
(defun make-safe-string (s)
"Escape strings for database export."
(and s (substitute-chars-strings
s +sql-control-characters+)))
;; Taken from clsql file sql/utils.lisp (under LLGPL).
(defun substitute-chars-strings (str repl-alist)
"Replace all instances of a chars with a string. repl-alist is an assoc
list of characters and replacement strings."
(declare (simple-string str)
(optimize (speed 3) (safety 0) (space 0)))
(do* ((orig-len (length str))
(new-string (make-string (replaced-string-length str repl-alist)))
(spos 0 (1+ spos))
(dpos 0))
((>= spos orig-len)
new-string)
(declare (fixnum spos dpos) (simple-string new-string))
(let* ((c (char str spos))
(match (assoc c repl-alist :test #'char=)))
(declare (character c))
(if match
(let* ((subst (cdr match))
(len (length subst)))
(declare (fixnum len)
(simple-string subst))
(dotimes (j len)
(declare (fixnum j))
(setf (char new-string dpos) (char subst j))
(incf dpos)))
(progn
(setf (char new-string dpos) c)
(incf dpos))))))
;; Taken from clsql file sql/utils.lisp (under LLGPL).
(defun replaced-string-length (str repl-alist)
(declare (simple-string str)
(optimize (speed 3) (safety 0) (space 0)))
(do* ((i 0 (1+ i))
(orig-len (length str))
(new-len orig-len))
((= i orig-len) new-len)
(declare (fixnum i orig-len new-len))
(let* ((c (char str i))
(match (assoc c repl-alist :test #'char=)))
(declare (character c))
(when match
(incf new-len (1- (length
(the simple-string (cdr match)))))))))
(defun set-session (client-id &key student problem section extra)
"Updates transaction with session information."
(unless client-id (error "set-session called with no client-id"))
(test-safe-string client-id student problem section extra)
(unless (> (length extra) 0) ;treat empty string as null
(setf extra nil)) ;drop from query if missing.
(with-db
;; Test that section entry already exits or create an empty one.
(unless
(query *connection*
(format nil
"SELECT classSection FROM CLASS_INFORMATION WHERE classSection = '~A'"
section)
)
(query *connection*
(format nil
"INSERT into CLASS_INFORMATION (classSection,description) values ('~A','unknown section')"
section)))
;; session is labeled by client-id
;; This sets up entry in PROBLEM attempt for a given session.
(query *connection*
(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 'log-condition:log-warn
:tag (list 'duplicate-client-id
client-id student
problem section extra)
:text "ClientID already exists in PROBLEM_ATTTEMPT."
))))
(defun truncate-string (x)
"Truncate arg for warning messages."
(subseq x 0 (min (length x) 400)))
(defmacro errors-to-warnings (object &rest forms)
"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 '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.
(truncate-string ,object))
:text (format nil "~A" c)))))
;; (andes-database:get-matching-sessions '("solution-step" "seek-help") :student "bvds" :problem "s2e" :section "1234")
;;
(defun get-matching-sessions (methods &key student problem section extra)
"Get posts associated with the given methods from all matching previous sessions."
(unless (> (length extra) 0) ;treat empty string as null.
(setf extra nil)) ;drop from query if missing.
(test-safe-string student problem section extra)
(with-db
(let ((result
(query *connection*
(if (and (> (length extra) 1)
(equal (subseq extra 0 2) "Q_"))
(format nil "SELECT server,client,STEP_TRANSACTION.clientID FROM PROBLEM_ATTEMPT,STEP_TRANSACTION WHERE userProblem='~A' AND userSection='~A' AND extra='~A' AND PROBLEM_ATTEMPT.clientID=STEP_TRANSACTION.clientID"
problem section extra)
(format nil "SELECT server,client,STEP_TRANSACTION.clientID FROM PROBLEM_ATTEMPT,STEP_TRANSACTION WHERE userName='~A' AND userProblem='~A' AND userSection='~A'~@[ AND extra='~A'~] AND PROBLEM_ATTEMPT.clientID=STEP_TRANSACTION.clientID"
(truncate-student student)
problem section extra) )
))
;; By default, cl-json turns camelcase into dashes:
;; Instead, we are case insensitive, preserving dashes.
(*json-identifier-name-to-lisp* #'string-upcase))
;; Filter out turns where the reply contains a timeout error.
;; Unless the bug causing the timeout has been fixed, these errors
;; prevent a student from reopening a problem.
(setf result
(remove-if
#'(lambda (x)
;; find client turn such that associated server
;; reply does not have a timeout error.
(and x
(server-reply-has-timeout
;; Actually, we only need to decode the
;; top-level list.
;; Sometimes result gets truncated on very long
;; backtraces. It might be better to just search
;; the string for the timeout message?
(errors-to-warnings x (decode-json-from-string x)))))
result
:key #'car))
;; parse json in each member of result
;; pick out post and client-id
(setf result
(mapcar
;; A post with no json sent gets translated into nil;
;; see write-transaction.
#'(lambda (x)
(let ((y (second x)))
(cons (and y
(errors-to-warnings
y
(decode-json-from-string y)))
(third x))))
result))
;; pick out the solution-step and get-help methods
(remove-if #'(lambda (x) (not (member (cdr (assoc :method x))
methods
:test #'equal)))
result
:key #'car))))
(defun server-reply-has-timeout (reply)
"Test whether a server reply includes a timeout error."
(some #'(lambda (x) (and (string-equal (cdr (assoc :action x)) "log")
(string-equal (cdr (assoc :error-type x))
"timeout")))
(cdr (assoc :result reply))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Access grade
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-score (&key student problem section extra)
"Get latest score."
(unless (> (length extra) 0) ;treat empty string as null.
(setf extra nil)) ;drop from query if missing.
(test-safe-string student problem section extra)
;; Assume every session has a grade reported somewhere in it.
;; Thus, we only need to search the most recent session.
;; Only methods open-problem, solution-step, get-help, close-problem should be searched.
;; open-problem puts a dummy set-score=0 at the beginning, but then the value
;; is updated as old sessions are rerun.
(with-db
(let* ((query (format nil "SELECT clientID FROM PROBLEM_ATTEMPT WHERE userName='~A' AND userProblem='~A' AND userSection='~A'~@[ AND extra='~A'~] ORDER BY startTime DESC LIMIT 1"
student problem section extra))
(client-id (car (car (query *connection* query))))
(results (when client-id
(query *connection*
(format nil "SELECT server FROM STEP_TRANSACTION WHERE clientID='~A'"
;; Here, client-id should be ok length
;; since it is from query.
client-id)
;:flatp t
)))
;; By default, cl-json turns camelcase into dashes:
;; Instead, we are case insensitive, preserving dashes.
(*json-identifier-name-to-lisp* #'string-upcase))
(when nil ;; debug prints
(unless client-id (format webserver:*stdout* "query ~S~%"
query))
(format webserver:*stdout* "db results for ~S:~% ~S~%"
client-id results))
;; Go through turns in a session backwords looking for
;; last set-score.
(dolist (result (reverse results))
;; Go through lines in a reply backwards looking for
;; the last set-score.
(dolist (line (reverse
(cdr (assoc :result
(when result
(errors-to-warnings
(car result)
(decode-json-from-string
(car result))))))))
(when (equal (cdr (assoc :action line)) "set-score")
(return-from get-score
(cdr (assoc :score line)))))))))
;;
;; Experiment-specific code. See Bug #1940
;;
;;
;; physics 2240A1
;; (andes-database::get-student-grades "uwplatt_51421910795174fcfuwplattl1_")
;; physics 2240A2
;; (andes-database::get-student-grades "uwplatt_6l13051599e174fb5uwplattl1_")
;; physics 2340C1
;; (andes-database::get-student-grades "uwplatt_2Y1305989a5174f1cuwplattl1_")
;; physics 2340C2
;; (andes-database::get-student-grades "uwplatt_3n13056a8a6174fbeuwplattl1_")
(defun get-student-grades (Section)
"Get list of scores for a given section."
(test-safe-string section)
(let* ((query (format nil "SELECT DISTINCT userName,userProblem FROM PROBLEM_ATTEMPT where userSection='~A'" Section))
(results (with-db (query *connection* query)))
x)
(dolist (result (sort results #'string-greaterp :key #'car))
(let ((score (get-score :student (car result)
:problem (second result)
:section Section)))
(when score (push (list (car result) (second result) score) x))))
(format t "~:{~A~t~A~t~A~%~}" x)))
(defun get-distinct-sections (Section-regexp)
"Get list of matching sections."
(test-safe-string section-regexp)
(let ((query (format nil "SELECT DISTINCT userSection FROM PROBLEM_ATTEMPT where userSection REGEXP '~A'" Section-regexp)))
(mapcar #'car (with-db (query *connection* query)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Access student and section customizations.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun single-query (x)
"Perform database query that expects a single column reply."
;; Do not use inside another with-db wrapper.
(let ((result
(mapcar #'car
(with-db (query *connection* x)))))
(when nil ;debug print
(format webserver:*stdout*
"database query:~% ~A~% ~A~% " x result))
result))
;; Only set these inside an old-sessions wrapper.
(defvar *disable-saving-state* nil)
(defvar *old-client-id* nil)
(defun set-old-session-start (client-id)
"Use client-id from old session to set session tID. Should be called inside an old-sessions wrapper."
(setf *old-client-id* client-id))
(defmacro old-sessions (&body body)
"Turn off writing state to database."
`(let ((*disable-saving-state* t) *old-client-id*) ,@body))
;; It would be more efficient if we cached the results for
;; this query. However, it cannot be cached as a session
;; variable because write-transaction cannot access session
;; variables.
;; A global cache would need periodic flushing.
(defun get-start-tID (client-id)
(let ((result
(query *connection*
(format nil "SELECT MIN(tID) FROM STEP_TRANSACTION WHERE clientID='~A'"
(truncate-client-id client-id)))))
(if (and (consp result) (consp (car result)))
(car (car result))
(warn 'log-condition:log-warn
:tag (list 'get-start-tID result
*old-client-id*
webserver:*log-id*
(truncate-client-id client-id))
:text "get-start-tID expecting list of lists"))))
(defun get-session-starting-tID ()
"Get any existing tID associated with the start of the current session. If client-id is a string, use that session."
;; Should cache result of this query.
(with-db (get-start-tID
(or *old-client-id* webserver:*log-id*))))
(defconstant +client-id-width+ 50
"Width of clientID column in table PROBLEM_ATTEMPT.")
(defun truncate-client-id (client-id)
"client-id in table is fixed width. Test if given string is too large, else any match will fail."
(if (> (length client-id) +client-id-width+)
(progn (warn "clientID too long ~A" client-id)
(subseq client-id 0 +client-id-width+))
client-id))
(defconstant +student-width+ 50 "Match userName in table PROBLEM_ATTEMPT.")
(defun truncate-student (student)
"Student name in database is fixed width. Test if given string is too large, else any match will fail."
(if (> (length student) +student-width+)
(progn (warn "userName too long ~A" student)
(subseq student 0 +student-width+))
student))
(defun get-most-recent-tID ()
"Get largest tID from STEP_TRANSACTION; if table is empty, create dummy step."
(loop for i from 0 to 1
thereis (car (single-query "SELECT MAX(tID) FROM STEP_TRANSACTION"))
do (write-transaction "_dummy_session" nil nil)))
(defun get-state-properties (&key (student session:*user*)
(section session:*section*) (model "default")
(tID (get-session-starting-tID)))
"Retrieve state parameters from the database. Model includes \"default\", \"client\", or \"server\". Returns an alist of property-value pairs. Null student returns section-wide results."
(let ((properties
(single-query
;; If student exists, still need to look for any section defaults
;; for the case
(format nil "SELECT DISTINCT property FROM STUDENT_STATE WHERE userSection='~A' AND (~@[userName='~A' OR ~]userName='') AND model='~A'~@[ AND tID<~A~]"
section (truncate-student student) model tID)))
result)
;; Add any cached properties.
(dolist (p session:*state-cache*)
(when (equal model (car (car p)))
(pushnew (cdr (car p)) properties :test #'equal)))
(dolist (property properties)
(multiple-value-bind (value flag)
(get-state-property property :section section :student student
:model model :tID tID)
;; Remove properties that have been deleted.
(when flag (push (cons property value) result))))
result))
(defun get-state-property (property &key (student session:*user*)
(section session:*section*) (model "default")
(tID (get-session-starting-tID)))
"Retrieve state parameter from the database. Model includes \"default\", \"client\", or \"server\". Returns value and flag indicating a value has been found. Null student returns section-wide results."
;; First, see if property is cached.
;; Using the cache is necessary for re-running old sessions.
;; Cache needs to be flushed between different old sessions.
(let ((x (assoc (cons model property) session:*state-cache* :test #'equal)))
(when x
(return-from get-state-property
(values (cdr x) t))))
;; Then look in database for student-specific match.
(when student
(let ((student-result
(single-query
(format nil "SELECT value FROM STUDENT_STATE WHERE userSection='~A' AND userName='~A' AND model='~A' AND property='~A'~@[ AND tID<~A~] ORDER BY tID DESC LIMIT 1"
section (truncate-student student) model property tID))))
(when (and student-result (car student-result))
(return-from get-state-property
(values (read-from-string (car student-result)) t)))))
;; Look for section-wide match.
(let ((section-result
(single-query
(format nil "SELECT value FROM STUDENT_STATE WHERE userSection='~A' AND userName='' AND model='~A' AND property='~A'~@[ AND tID<~A~] ORDER BY tID DESC LIMIT 1"
section model property tID))))
(when (and section-result (car section-result))
(return-from get-state-property
(values (read-from-string (car section-result)) t))))
;; Nothing found
(values nil nil))
(defun set-state-property (property value &key
(student session:*user*)
(section session:*section*)
(model "default")
no-store
tID)
"Update a student or section state parameter. If value is null, delete
that parameter. If tID is not specified, insert at end of turn;
if it is an integer, insert directly with specified tID;
otherwise, use latest step tID. No-store means add to cache only."
;; Test that student is not empty string.
;; 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 'log-condition:log-error :tag 'empty-student-string
:text "Null string sent for student"))
;; Save in cache, by either updating or pushing
(unless tID
(let ((x (assoc (cons model property) session:*state-cache*
:test #'equal)))
(if x
(setf (cdr x) value)
(push (cons (cons model property) value) session:*state-cache*))))
(unless (or *disable-saving-state* no-store)
;; Save to STUDENT_STATE either now or later.
(let ((query-format-string
(format nil "REPLACE into STUDENT_STATE (userSection,userName,model,property,tID,value) VALUES ('~A',~:[''~;~:*'~A'~],'~A','~A',~~A,~:[NULL~*~;'~A'~])"
section student model
(if (stringp property) property (prin1-to-string property))
;; tID itself is passed in by the logging function.
value
(when value (make-safe-string (prin1-to-string value))))))
;; If tID is specified, insert directly at that point,
;; else insert into beginning of session after step is completed.
(if tID
(progn
(unless (integerp tID) (setf tID (get-most-recent-tID)))
;; (format t query-format-string tID)
(with-db
(query *connection*
(format nil query-format-string tID))))
(push query-format-string webserver:*log-variable*)))))
Jump to Line
Something went wrong with that request. Please try again.