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