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 destructors
   6 continuations ;
   7 IN: db.queries
   8
   9 GENERIC: where ( specs obj -- )
  10
  11 SINGLETON: retryable
  12 : make-retryable ( obj -- obj' )
  13     dup sequence? [
  14         [ make-retryable ] map
  15     ] [
  16         retryable >>type
  17         10 >>retries
  18     ] if ;
  19
  20 : maybe-make-retryable ( statement -- statement )
  21     dup in-params>> [ generator-bind? ] contains?
  22     [ make-retryable ] when ;
  23
  24 : regenerate-params ( statement -- statement )
  25     dup
  26     [ bind-params>> ] [ in-params>> ] bi
  27     [
  28         dup generator-bind? [
  29             generator-singleton>> eval-generator >>value
  30         ] [
  31             drop
  32         ] if
  33     ] 2map >>bind-params ;
  34
  35 M: retryable execute-statement* ( statement type -- )
  36     drop [ retries>> ] [
  37         [
  38             nip
  39             [ query-results dispose t ]
  40             [ ]
  41             [ regenerate-params bind-statement* f ] cleanup
  42         ] curry
  43     ] bi attempt-all drop ;
  44
  45 : sql-props ( class -- columns table )
  46     [ db-columns ] [ db-table ] bi ;
  47
  48 : query-make ( class quot -- )
  49     >r sql-props r>
  50     [ 0 sql-counter rot with-variable ] curry { "" { } { } } nmake
  51     <simple-statement> maybe-make-retryable ; inline
  52
  53 : where-primary-key% ( specs -- )
  54     " where " 0%
  55     find-primary-key dup column-name>> 0% " = " 0% bind% ;
  56
  57 M: db <update-tuple-statement> ( class -- statement )
  58     [
  59         "update " 0% 0%
  60         " set " 0%
  61         dup remove-id
  62         [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
  63         where-primary-key%
  64     ] query-make ;
  65
  66 M: random-id-generator eval-generator ( singleton -- obj )
  67     drop
  68     system-random-generator get [
  69         63 [ random-bits ] keep 1- set-bit
  70     ] with-random ;
  71
  72 : interval-comparison ( ? str -- str )
  73     "from" = " >" " <" ? swap [ "= " append ] when ;
  74
  75 : (infinite-interval?) ( interval -- ?1 ?2 )
  76     [ from>> ] [ to>> ] bi
  77     [ first fp-infinity? ] bi@ ;
  78
  79 : double-infinite-interval? ( obj -- ? )
  80     dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
  81
  82 : infinite-interval? ( obj -- ? )
  83     dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
  84
  85 : where-interval ( spec obj from/to -- )
  86     over first fp-infinity? [
  87         3drop
  88     ] [
  89         pick column-name>> 0%
  90         >r first2 r> interval-comparison 0%
  91         bind#
  92     ] if ;
  93
  94 : in-parens ( quot -- )
  95     "(" 0% call ")" 0% ; inline
  96
  97 M: interval where ( spec obj -- )
  98     [
  99         [ from>> "from" where-interval ] [
 100             nip infinite-interval? [ " and " 0% ] unless
 101         ] [ to>> "to" where-interval ] 2tri
 102     ] in-parens ;
 103
 104 M: sequence where ( spec obj -- )
 105     [
 106         [ " or " 0% ] [ dupd where ] interleave drop
 107     ] in-parens ;
 108
 109 : object-where ( spec obj -- )
 110     over column-name>> 0% " = " 0% bind# ;
 111
 112 M: object where ( spec obj -- ) object-where ;
 113
 114 M: integer where ( spec obj -- ) object-where ;
 115
 116 M: string where ( spec obj -- ) object-where ;
 117
 118 : filter-slots ( tuple specs -- specs' )
 119     [
 120         slot-name>> swap get-slot-named
 121         dup double-infinite-interval? [ drop f ] when
 122     ] with filter ;
 123
 124 : where-clause ( tuple specs -- )
 125     dupd filter-slots [
 126         drop
 127     ] [
 128         " where " 0% [
 129             " and " 0%
 130         ] [
 131             2dup slot-name>> swap get-slot-named where
 132         ] interleave drop
 133     ] if-empty ;
 134
 135 M: db <delete-tuples-statement> ( tuple table -- sql )
 136     [
 137         "delete from " 0% 0%
 138         where-clause
 139     ] query-make ;
 140
 141 M: db <select-by-slots-statement> ( tuple class -- statement )
 142     [
 143         "select " 0%
 144         over [ ", " 0% ]
 145         [ dup column-name>> 0% 2, ] interleave
 146
 147         " from " 0% 0%
 148         where-clause
 149     ] query-make ;
 150
 151 : do-group ( tuple groups -- )
 152     [
 153         ", " join " group by " swap 3append
 154     ] curry change-sql drop ;
 155
 156 : do-order ( tuple order -- )
 157     [
 158         ", " join " order by " swap 3append
 159     ] curry change-sql drop ;
 160
 161 : do-offset ( tuple n -- )
 162     [
 163         number>string " offset " swap 3append
 164     ] curry change-sql drop ;
 165
 166 : do-limit ( tuple n -- )
 167     [
 168         number>string " limit " swap 3append
 169     ] curry change-sql drop ;
 170
 171 : make-query ( tuple query -- tuple' )
 172     dupd
 173     {
 174         [ group>> [ drop ] [ do-group ] if-empty ]
 175         [ order>> [ drop ] [ do-order ] if-empty ]
 176         [ limit>> [ do-limit ] [ drop ] if* ]
 177         [ offset>> [ do-offset ] [ drop ] if* ]
 178     } 2cleave ;
 179
 180 M: db <query> ( tuple class query -- tuple )
 181     [ <select-by-slots-statement> ] dip make-query ;
 182
 183 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
 184
 185 : select-tuples* ( tuple -- statement )
 186     dup
 187     [
 188         select 0,
 189         dup class db-columns [ ", " 0, ]
 190         [ dup column-name>> 0, 2, ] interleave
 191         from 0,
 192         class name>> 0,
 193     ] { { } { } { } } nmake
 194     >r >r parse-sql 4drop r> r>
 195     <simple-statement> maybe-make-retryable do-select ;
 196
 197 M: db <count-statement> ( tuple class groups -- statement )
 198     \ query new
 199         swap >>group
 200     [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
 201     dip make-query ;
 202
 203 : create-index ( index-name table-name columns -- )
 204     [
 205         >r >r "create index " % % r> " on " % % r> "(" %
 206         "," join % ")" %
 207     ] "" make sql-command ;
 208
 209 : drop-index ( index-name -- )
 210     [ "drop index " % % ] "" make sql-command ;