Coverage report: /home/samppa/personal/opiskelu/ohtuprojekti/pulsu/trunk/controller.lisp

KindCoveredAll%
expression144429 33.6
branch2058 34.5
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ; This file contains the database part of the controller
2
 
3
 (in-package :puls.controller)
4
 
5
 (defparameter *database-table* "plus")
6
 
7
 (defun connect-to-db (&optional (host "127.0.0.1"))
8
   (clsql:connect (list host "pulsu" "remote" "remotepulsu"
9
                        13326) :database-type :mysql :pool t)
10
   ;; UFFI seems to send utf-8 to the database, regardless of the
11
   ;; locale.
12
   (clsql-sys:execute-command "set names utf8"))
13
 
14
 
15
 ;#.(locally-enable-sql-reader-syntax)
16
 
17
 (defun get-event (docno event_id)
18
   "Gets a single ie-event, identified by document number and event_id
19
   Returns something like (:field1 \"content\" :field2 \"content\" ...)"
20
   (first 
21
    (my-query (format nil "select * from ~A
22
                           where docno = '~A' and event_id = '~A'"
23
                      *database-table*
24
                      docno
25
                      event_id))))
26
 
27
 (defun set-event (docno event_id row)
28
   "Sets fields of event identified by (docno,event_id). Row is a plist
29
   with attributes.
30
   Example: (set-event \"20050111_timesofindia_562b0491fe61ac9f38b60e45008bdd63\" 2 '(:group_number 0 :verify \"verified\"))"
31
   (execute-command
32
    (format nil "UPDATE ~A SET ~A WHERE docno='~A' and event_id=~A"
33
            *database-table*
34
            (format-plist row)
35
            docno
36
            event_id)))
37
 
38
 (defun add-event (docno row)
39
   "Adds a new event to document docno with attributes from row.
40
   NB! docno and event_id should _not_ be set in row"
41
   (with-transaction ()
42
     (let ((event_id
43
            (first (first (query
44
                           (format nil "SELECT MAX(event_id)+1
45
                                          FROM (
46
                                           SELECT * FROM ~A
47
                                           UNION
48
                                           SELECT * FROM ~Adeleted) AS FOO
49
                                          WHERE docno = '~A'"
50
                                     *database-table*
51
                                     *database-table*
52
                                     docno))))))
53
       (execute-command
54
        (format nil
55
                "INSERT INTO ~A SET ~A,docno = '~A',event_id = ~A"
56
                *database-table*
57
                (format-plist row)
58
                docno
59
                event_id))
60
       (reunify-event docno event_id))))
61
 
62
 
63
 (defun get-max-event (docno)
64
 (query (format nil "SELECT MAX(event_id) FROM plus WHERE docno = '~A'" docno)))
65
 
66
 ;; NB! the following three functions are not yet scenario-generic!!
67
 (defun count-unified-case (group_number)
68
   (execute-command
69
    (format nil "UPDATE unified SET member_count = (SELECT count(*) FROM ~A WHERE group_number=unified.id) WHERE id=~A"
70
            *database-table*
71
            group_number))) 
72
 
73
 (defun get-unification-candidates (row)
74
   (my-query
75
    (format nil
76
            "SELECT id FROM unified WHERE 
77
             disease='~A' AND country='~A' AND
78
             start_time='~A' AND end_time='~A'"
79
            (getf row :disease_canon)
80
            (getf row :country)
81
            (getf row :norm_stime)
82
            (getf row :norm_etime)))) 
83
 
84
 (defun reunify-event (docno event_id)
85
   "Find a new unified group for event identified by (docno,event_id). If no matching ones found, create a new one"
86
   (with-transaction ()
87
     (let* ((row (get-event docno event_id))
88
            (oldgroup (getf row :group_number))
89
            (candidates (get-unification-candidates row))
90
                                         ; insert real heuristic here:
91
            (chosen (getf (first candidates) :id)))
92
                                         ; ensure that a group for the event exists
93
       (when (null chosen)
94
         (execute-command
95
          (format nil "INSERT INTO unified
96
                       (disease,country,start_time,end_time,member_count)
97
                       VALUES
98
                       ('~A','~A','~A','~A',0)"
99
                  (getf row :disease_canon)
100
                  (getf row :country)
101
                  (getf row :norm_stime)
102
                  (getf row :norm_etime)))       
103
         (setf chosen (getf (first (get-unification-candidates row)) :id))
104
         (print "LOL")
105
         (print chosen))
106
                                         ; do it
107
       (execute-command
108
        (format nil "UPDATE ~A, unified SET group_number = ~A
109
                 WHERE
110
                 ~A.docno = '~A' AND ~A.event_id = ~A"
111
                *database-table*
112
                chosen
113
                *database-table*
114
                docno
115
                *database-table*
116
                event_id))
117
       (count-unified-case chosen)
118
       (when (not (null oldgroup))
119
         (count-unified-case oldgroup)))))
120
   
121
 
122
 (defun get-newest-events (&key (skip 0) (n 0) filter (show-accepted "all"))
123
   "Gets newest events, max. n results. Skips skip newest ones.
124
   Returns something like ((:field1 \"content\" :field2 \"content\" ...) ...)"
125
   (my-query
126
    (format nil
127
            "SELECT * FROM ~A WHERE ~A ~A
128
                      ORDER BY doc_date DESC
129
                      LIMIT ~A OFFSET ~A"
130
            *database-table*
131
            (if (null filter)
132
                "1=1"
133
                (format-filter filter))
134
            (cond
135
              ((string= show-accepted "unverified")
136
               "AND verify IS NULL")
137
              ((string= show-accepted "verified")
138
               "AND verify IS NOT NULL")
139
              (t
140
               ""))
141
            n skip)))
142
 
143
 
144
 (defun get-document-events (docno)
145
   "Returns all events from a single document."
146
   (my-query
147
    (format nil
148
            "SELECT * FROM ~A
149
              WHERE docno = '~A'"
150
            *database-table*
151
            docno)))
152
 
153
 (defun reject-event (docno event_id)
154
   (execute-command
155
    (format nil
156
            "INSERT INTO ~Adeleted SELECT * FROM ~A WHERE docno='~A' AND event_id=~A"
157
            *database-table*
158
            *database-table*
159
            docno
160
            event_id))
161
   (execute-command
162
    (format nil
163
            "DELETE FROM ~A WHERE docno='~A' AND event_id=~A"
164
            *database-table*
165
            docno
166
            event_id)))
167
            
168
 
169
 ;;
170
 
171
 (defun get-unified-case (group_number
172
                          &key (show-accepted "all")
173
                               filter)
174
   "Get list of rows that is the unified case identified by group_number.
175
   show-accepted is \"all\", \"verified\", \"unverified\""
176
   (my-query (format nil "SELECT * from ~A where group_number = ~A ~A ~A"
177
                     *database-table*
178
                     group_number
179
                     (if (null filter)
180
                         ""
181
                         (concatenate 'string " AND "
182
                                      (format-filter filter)))
183
                     (cond
184
                       ((string=  show-accepted "unverified")
185
                        "AND verify IS NULL")
186
                       ((string= show-accepted "verified")
187
                        "AND verify IS NOT NULL")
188
                       (t
189
                        "")))))
190
 
191
 (deftest test-get-newest-unified-cases ()
192
   (puls.test::map-check
193
    (lambda (case)
194
      (check
195
        (apply #'= (mapcar (lambda (x) (getf x :group_number))
196
                           case))))
197
    (get-newest-unified-cases :skip 10 :n 10)))
198
 (defun get-newest-unified-cases
199
     (&key (skip 0) (n 0) (show-accepted "all") filter)
200
   "Like get-newest-events, but each event gets replaced by a list of
201
   events with the same group_number. show-accepted controls whether to
202
   include verified cases."
203
   (loop :for row :in
204
      (my-query (format nil "SELECT group_number FROM ~A
205
                             ~A
206
                             GROUP BY group_number
207
                             ~A
208
                             ORDER BY doc_date DESC
209
                             LIMIT ~A OFFSET ~A
210
                             "
211
                        *database-table*
212
                        (cond ((string= show-accepted "verified")
213
                               "HAVING count(verify)>0")
214
                              (t
215
                               ""))
216
                        (if (null filter)
217
                            ""
218
                            (format nil "WHERE ~A" (format-filter filter)))
219
                        n skip))
220
      :collect
221
      (get-unified-case (getf row :group_number)
222
                        :show-accepted show-accepted
223
                        )))
224
                                 
225
 
226
 (defun verify-unified-case (group_number string)
227
   (execute-command
228
    (format nil "UPDATE unified SET verify='~A' WHERE id=~A"
229
            string
230
            group_number)))
231
 
232
 
233
 ;#.(restore-sql-reader-syntax-state)
234
 
235
 ;;;; internal helper functions start here
236
 
237
 (defun keywordify (string)
238
   "Maps \"asdf\" => :asdf"
239
   (intern (string-upcase string) :keyword))
240
 
241
 (defun row-plist (row field-keywords)
242
   "Maps (:fieldname1 :fieldname2 :fieldname3) (val1 val2 val3)
243
   => (:fieldname1 val1 :fieldname2 val2 :fieldname3 val3)"
244
   (loop :for i :in row 
245
         :for j :in field-keywords
246
         :collect j
247
         :collect i))
248
 
249
 (deftest test-format-plist ()
250
   (check (equal (format-plist '(:lol "moi" :foo 2))
251
                 "LOL = 'moi',FOO = 2")))
252
 (deftest test2-format-plist ()
253
   (check (equal (format-plist '(:lol "moi" :foo 2) " AND ")
254
                 "LOL = 'moi' AND FOO = 2")))
255
 (defun format-plist (plist &optional (separator ","))
256
   "Maps (:field1 val1 :field2 val2) => \"field1=val1,field2=val2\"
257
 separator \",\" can be changed to what is needed. Example to \" AND \""
258
    (apply #'concatenate 'string
259
           (nbutlast
260
            (loop :for (i j) :in (plist-avpairs plist)
261
                  :collecting
262
               (format nil "~A = ~A"
263
                       (string i)
264
                       (puls.database:database-format-value j))
265
               :collecting separator))))
266
 
267
 (defun format-filter (plists)
268
   "Format a list of plists into a filter (a sql expression)"
269
   (if (null plists)
270
       "1=1"
271
       (apply #'concatenate 'string
272
              (nbutlast
273
               (loop :for p :in plists
274
                     :when p
275
                     :collect (format-plist p " AND ") :and
276
                     :collect " OR ")))))
277
 
278
 (deftest test-plist-avpairs ()
279
   (check
280
     (equalp (plist-avpairs '(:foo "LOL" :bar 1))
281
             '((:foo "LOL") (:bar 1)))))
282
 (defun plist-avpairs (plist)
283
   "Maps (:field1 val1 :field2 val2) => ((:field1 val1) (:field2 val2))"
284
   (loop :for (field val) :on plist :by #'cddr
285
         :collect (list field val)))
286
 
287
 (defun my-query (&rest args)
288
   "Wrapper around clsql:query that returns a list of plists
289
   (my-query \"select * from plus\") =>
290
   ((:DOCNO \"20051231_NEWScomAU_73ef10bed6da82fc1bba1c8c779c133a\" :DOC_DATE
291
    \"2005.12.31\" :DISEASE_NAME \"bird flu\" ...)
292
    (:DOCNO \"20051231_TheAustralian_0c5cfe218c0da516616cec1bdfa58cf5\"... )
293
    ...)" 
294
   (multiple-value-bind (rows cols) (apply #'query args)
295
     (loop :for row :in rows
296
           :collect (row-plist row (mapcar #'keywordify cols)))))
297
 
298
 (defun my-select (&rest args)
299
   "Same as my-query but for clsql:select"
300
   (multiple-value-bind (rows cols) (apply #'select args)
301
     (loop :for row :in rows
302
           :collect (row-plist row (mapcar #'keywordify cols)))))
303
 
304
 (deftest test-subseqs ()
305
   (check (equal (subseqs "abcdefghijkl" '(1 2 5 8))
306
                 '("b" "fgh"))))
307
 (defun subseqs (seq li)
308
   "(subseqs \"abcdefghij\" '(1 3 5 10)) => (\"bc\" \"fghij\")"
309
   (loop :for (beg end) :on li :by #'cddr
310
         :collect (subseq seq beg end)))
311
 
312
 (defun get-map-kml (maplist &optional (table-name *database-table*))
313
   "Fetches cases related to MAPLIST from TABLE-NAME and generates
314
   kml data to *STANDARD-OUTPUT*. MAPLIST is list of attributes.
315
   Example: (get-map-kml '(:country \"zambia\" :disease_canon \"hiv\"))"
316
   (let* ((events (clsql:query 
317
                   (format nil "select country, location, ~
318
 count(*), disease_canon from ~A where ~A ~
319
 group by country, location, disease_canon"
320
                           table-name (format-plist maplist " AND "))))
321
          
322
          (locs (loop :for (a b c d ) :in events
323
                      :collect (puls.maps::make-puls-maps-location
324
                                a b c (list :disease d)))))
325
     (puls.maps::write-kml locs
326
                           :country-description-fn
327
                           'puls.maps::puls-maps-example-disease-country-description-fn
328
                           :loc-description-fn 
329
                           'puls.maps::puls-maps-example-disease-loc-description-fn)))
330
 
331
 
332
 
333
 
334
 
335
 (defun loc-describe())
336
 
337
 
338
 (defun make-map-kml (events country-description-fn loc-description-fn)
339
   "Fetches cases related to MAPLIST from TABLE-NAME and generates
340
   kml data to *STANDARD-OUTPUT*. MAPLIST is list of attributes.
341
   Example: (get-map-kml '(:country \"zambia\" :disease_canon \"hiv\"))"
342
   (let* ((locs (loop :for case :in events
343
                      :collect (puls.maps::make-puls-maps-location (getf case :country) (getf case :location) 1 (list :disease (getf case :disease_canon))))))
344
  
345
   (puls.maps::write-kml locs
346
                         :country-description-fn country-description-fn
347
                         ;'puls.maps::puls-maps-example-disease-country-description-fn
348
                         :loc-description-fn loc-description-fn
349
                         ;'puls.maps::puls-maps-example-disease-loc-description-fn
350
 )))
351
 
352
 
353
 (defun authenticate-user ()
354
   "user authentication"
355
   (multiple-value-bind (user password) 
356
       (hunchentoot:authorization)
357
     (if (not (equal 
358
               password
359
               (string (first (first (clsql:query (format nil "select password from user where name = '~A'" user)))))))
360
         (hunchentoot:require-authorization))))
361
 
362
 ;;;;
363
 
364
 (deftest test-controller ()
365
   (combine-results
366
     (test-format-plist)
367
     (test2-format-plist)
368
     (test-subseqs)
369
     (test-get-newest-unified-cases)
370
     (test-plist-avpairs)
371
     (test-get-document-auxil)
372
     (test-get-values-date-start)
373
     (test-get-values-date-end)
374
     (test-get-values-disease)
375
     (test-get-values-state)
376
     ))