entity-filter.ss 4.23 KB
Newer Older
Dave Griffiths's avatar
Dave Griffiths committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52
#lang racket

;; Starwisp Copyright (C) 2014 Dave Griffiths
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program 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 Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(require
 "../web/scripts/utils.ss"
 "../web/scripts/sql.ss"
 "ktv.ss"
 "ktv-list.ss"
 "entity-values.ss"
 "entity-insert.ss"
 "entity-get.ss"
 "entity-update.ss")

(provide (all-defined-out))

;; filter is list of (attribute-key type op arg) e.g. ("gender" "varchar" "=" "Female")
;; note: only one filter per key..

(define (make-filter k t o a) (list k t o a))
(define (filter-key f) (list-ref f 0))
(define (filter-type f) (list-ref f 1))
(define (filter-op f) (list-ref f 2))
(define (filter-arg f) (list-ref f 3))

(define (merge-filter f fl)
  (cond
   ((null? fl) (list f))
   ((equal? (filter-key (car fl)) (filter-key f))
    (cons f (cdr fl)))
   (else (cons (car fl) (merge-filter f (cdr fl))))))

(define (delete-filter key fl)
  (cond
   ((null? fl) '())
   ((equal? (filter-key (car fl)) key)
    (cdr fl))
   (else (cons (car fl) (delete-filter key (cdr fl))))))

dave griffiths's avatar
dave griffiths committed
53 54 55 56 57 58 59 60 61 62 63
;; replace - with _
(define (mangle var)
  (list->string
   (map
    (lambda (c)
      (cond
       ((eqv? c #\-) #\_)
       (else c)))
    (string->list var))))

(define (build-query table filter typed)
Dave Griffiths's avatar
Dave Griffiths committed
64 65 66
  (string-append
   (foldl
    (lambda (i r)
dave griffiths's avatar
dave griffiths committed
67
      (let ((var (mangle (string-append (filter-key i) "_var"))))
Dave Griffiths's avatar
Dave Griffiths committed
68 69 70 71 72 73 74 75 76 77 78 79 80
        ;; add a query chunk
        (string-append
         r "join " table "_value_" (filter-type i) " "
         "as " var " on "
         var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and "
         var ".value " (filter-op i) " ? ")))

    ;; boilerplate query start
    (string-append
     "select e.entity_id from " table "_entity as e "
     ;; order by name
     "join " table "_value_varchar "
     "as n on n.entity_id = e.entity_id and n.attribute_id = 'name' "
dave griffiths's avatar
dave griffiths committed
81 82
     ;; ignore deleted (if exists)
     "left join " table "_value_int "
Dave Griffiths's avatar
Dave Griffiths committed
83
     "as d on d.entity_id = e.entity_id and d.attribute_id = 'deleted' and "
dave griffiths's avatar
dave griffiths committed
84
     "d.value = 0 or d.value = NULL ")
Dave Griffiths's avatar
Dave Griffiths committed
85
    filter)
dave griffiths's avatar
dave griffiths committed
86 87
   (if typed "where e.entity_type = ? order by n.value"
       "order by n.value")))
Dave Griffiths's avatar
Dave Griffiths committed
88

Dave Griffiths's avatar
Dave Griffiths committed
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
(define (build-query-inc-deleted table filter)
  (string-append
   (foldl
    (lambda (i r)
      (let ((var (string-append (filter-key i) "_var")))
        ;; add a query chunk
        (string-append
         r "join " table "_value_" (filter-type i) " "
         "as " var " on "
         var ".entity_id = e.entity_id and " var ".attribute_id = '" (filter-key i) "' and "
         var ".value " (filter-op i) " ? ")))

    ;; boilerplate query start
    (string-append
     "select e.entity_id from " table "_entity as e "
     ;; order by name
     "join " table "_value_varchar "
     "as n on n.entity_id = e.entity_id and n.attribute_id = 'name' ")
    filter)
   "where e.entity_type = ? order by n.value"))


Dave Griffiths's avatar
Dave Griffiths committed
111 112 113 114 115 116 117
(define (build-args filter)
  (map
   (lambda (i)
     (filter-arg i))
   filter))

(define (filter-entities db table type filter)
118
  (let ((q (build-query table filter)))
dave griffiths's avatar
merged  
dave griffiths committed
119 120 121 122 123 124 125 126 127 128 129 130 131
    (let ((s (apply
	      db-select
	      (append
	       (list db q)
	       (build-args filter)
	       (list type)))))
      (msg (db-status db))
      (if (null? s)
	  '()
	  (map
	   (lambda (i)
	     (vector-ref i 0))
	   (cdr s))))))
Dave Griffiths's avatar
Dave Griffiths committed
132 133 134

(define (filter-entities-inc-deleted db table type filter)
  (let ((q (build-query-inc-deleted table filter)))
Dave Griffiths's avatar
Dave Griffiths committed
135 136
  (let ((s (apply
            db-select
dave griffiths's avatar
dave griffiths committed
137 138 139 140
            (append
             (list db (build-query table filter (not (equal? type "*"))))
             (build-args filter)
             (if (equal? type "*") '() (list type))))))
Dave Griffiths's avatar
Dave Griffiths committed
141 142 143 144 145 146
    (msg (db-status db))
    (if (null? s)
        '()
        (map
         (lambda (i)
           (vector-ref i 0))
Dave Griffiths's avatar
Dave Griffiths committed
147
         (cdr s))))))