entity-filter.ss 3.14 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 89 90 91 92 93 94 95 96 97

(define (build-args filter)
  (map
   (lambda (i)
     (filter-arg i))
   filter))

(define (filter-entities db table type filter)
  (let ((s (apply
            db-select
dave griffiths's avatar
dave griffiths committed
98 99 100 101
            (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
102 103 104 105 106 107 108
    (msg (db-status db))
    (if (null? s)
        '()
        (map
         (lambda (i)
           (vector-ref i 0))
         (cdr s)))))