basis/db/queries/queries.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel math namespaces sequences random strings
   4 math.parser math.intervals combinators math.bitwise nmake db
   5 db.tuples db.types db.sql classes words shuffle arrays ;
   6 IN: db.queries
   7
   8 GENERIC: where ( specs obj -- )
   9
  10 : maybe-make-retryable ( statement -- statement )
  11     dup in-params>> [ generator-bind? ] contains?
  12     [ make-retryable ] when ;
  13
  14 : query-make ( class quot -- )
  15     >r sql-props r>
  16     [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
  17     <simple-statement> maybe-make-retryable ; inline
  18
  19 M: db begin-transaction ( -- ) "BEGIN" sql-command ;
  20 M: db commit-transaction ( -- ) "COMMIT" sql-command ;
  21 M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
  22
  23 : where-primary-key% ( specs -- )
  24     " where " 0%
  25     find-primary-key dup column-name>> 0% " = " 0% bind% ;
  26
  27 M: db <update-tuple-statement> ( class -- statement )
  28     [
  29         "update " 0% 0%
  30         " set " 0%
  31         dup remove-id
  32         [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
  33         where-primary-key%
  34     ] query-make ;
  35
  36 M: random-id-generator eval-generator ( singleton -- obj )
  37     drop
  38     system-random-generator get [
  39         63 [ 2^ random ] keep 1 - set-bit
  40     ] with-random ;
  41
  42 : interval-comparison ( ? str -- str )
  43     "from" = " >" " <" ? swap [ "= " append ] when ;
  44
  45 : (infinite-interval?) ( interval -- ?1 ?2 )
  46     [ from>> ] [ to>> ] bi
  47     [ first fp-infinity? ] bi@ ;
  48
  49 : double-infinite-interval? ( obj -- ? )
  50     dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
  51
  52 : infinite-interval? ( obj -- ? )
  53     dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
  54
  55 : where-interval ( spec obj from/to -- )
  56     over first fp-infinity? [
  57         3drop
  58     ] [
  59         pick column-name>> 0%
  60         >r first2 r> interval-comparison 0%
  61         bind#
  62     ] if ;
  63
  64 : in-parens ( quot -- )
  65     "(" 0% call ")" 0% ; inline
  66
  67 M: interval where ( spec obj -- )
  68     [
  69         [ from>> "from" where-interval ] [
  70             nip infinite-interval? [ " and " 0% ] unless
  71         ] [ to>> "to" where-interval ] 2tri
  72     ] in-parens ;
  73
  74 M: sequence where ( spec obj -- )
  75     [
  76         [ " or " 0% ] [ dupd where ] interleave drop
  77     ] in-parens ;
  78
  79 : object-where ( spec obj -- )
  80     over column-name>> 0% " = " 0% bind# ;
  81
  82 M: object where ( spec obj -- ) object-where ;
  83
  84 M: integer where ( spec obj -- ) object-where ;
  85
  86 M: string where ( spec obj -- ) object-where ;
  87
  88 : filter-slots ( tuple specs -- specs' )
  89     [
  90         slot-name>> swap get-slot-named
  91         dup double-infinite-interval? [ drop f ] when
  92     ] with filter ;
  93
  94 : where-clause ( tuple specs -- )
  95     dupd filter-slots [
  96         drop
  97     ] [
  98         " where " 0% [
  99             " and " 0%
 100         ] [
 101             2dup slot-name>> swap get-slot-named where
 102         ] interleave drop
 103     ] if-empty ;
 104
 105 M: db <delete-tuples-statement> ( tuple table -- sql )
 106     [
 107         "delete from " 0% 0%
 108         where-clause
 109     ] query-make ;
 110
 111 M: db <select-by-slots-statement> ( tuple class -- statement )
 112     [
 113         "select " 0%
 114         over [ ", " 0% ]
 115         [ dup column-name>> 0% 2, ] interleave
 116
 117         " from " 0% 0%
 118         where-clause
 119     ] query-make ;
 120
 121 : do-group ( tuple groups -- )
 122     [
 123         ", " join " group by " prepend append
 124     ] curry change-sql drop ;
 125
 126 : do-order ( tuple order -- )
 127     [
 128         ", " join " order by " prepend append
 129     ] curry change-sql drop ;
 130
 131 : do-offset ( tuple n -- )
 132     [
 133         number>string " offset " prepend append
 134     ] curry change-sql drop ;
 135
 136 : do-limit ( tuple n -- )
 137     [
 138         number>string " limit " prepend append
 139     ] curry change-sql drop ;
 140
 141 : make-query ( tuple query -- tuple' )
 142     dupd
 143     {
 144         [ group>> [ drop ] [ do-group ] if-empty ]
 145         [ order>> [ drop ] [ do-order ] if-empty ]
 146         [ limit>> [ do-limit ] [ drop ] if* ]
 147         [ offset>> [ do-offset ] [ drop ] if* ]
 148     } 2cleave ;
 149
 150 M: db <query> ( tuple class query -- tuple )
 151     [ <select-by-slots-statement> ] dip make-query ;
 152
 153 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
 154
 155 : select-tuples* ( tuple -- statement )
 156     dup
 157     [
 158         select 0,
 159         dup class db-columns [ ", " 0, ]
 160         [ dup column-name>> 0, 2, ] interleave
 161         from 0,
 162         class name>> 0,
 163     ] { { } { } { } } nmake
 164     >r >r parse-sql 4drop r> r>
 165     <simple-statement> maybe-make-retryable do-select ;
 166
 167 M: db <count-statement> ( tuple class groups -- statement )
 168     \ query new
 169         swap >>group
 170     [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
 171     dip make-query ;
 172
 173 : create-index ( index-name table-name columns -- )
 174     [
 175         >r >r "create index " % % r> " on " % % r> "(" %
 176         "," join % ")" %
 177     ] "" make sql-command ;
 178
 179 : drop-index ( index-name -- )
 180     [ "drop index " % % ] "" make sql-command ;