basis/db/queries/queries.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays byte-arrays classes classes.tuple
   4 combinators continuations db db.errors db.tuples
   5 db.tuples.private db.types destructors kernel make math
   6 math.bitwise math.intervals math.parser namespaces nmake random
   7 sequences strings ;
   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*
  37     drop [ retries>> <iota> ] [
  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 ( ..a class quot: ( ..a columns table -- ..b ) -- ..b statements )
  50     ! query, input, outputs, secondary queries
  51     [ sql-props ] dip
  52     '[ 0 sql-counter [ dup "table-name" set @ ] with-variable ]
  53     { "" { } { } { } } nmake
  54     [ <simple-statement> maybe-make-retryable ] dip
  55     [ [ 1array ] dip append ] unless-empty ; inline
  56
  57 : where-primary-key% ( specs -- )
  58     " where " 0%
  59     find-primary-key [
  60         " and " 0%
  61     ] [
  62         dup column-name>> 0% " = " 0% bind%
  63     ] interleave ;
  64
  65 M: db-connection <update-tuple-statement>
  66     [
  67         "update " 0% 0%
  68         " set " 0%
  69         dup remove-id
  70         [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
  71         where-primary-key%
  72     ] query-make ;
  73
  74 M: random-id-generator eval-generator
  75     drop
  76     system-random-generator get [
  77         63 [ random-bits ] keep 1 - set-bit
  78     ] with-random ;
  79
  80 : interval-comparison ( ? str -- str )
  81     "from" = " >" " <" ? swap [ "= " append ] when ;
  82
  83 : (infinite-interval?) ( interval -- ?1 ?2 )
  84     [ from>> ] [ to>> ] bi
  85     [ first fp-infinity? ] bi@ ;
  86
  87 : double-infinite-interval? ( obj -- ? )
  88     dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
  89
  90 : infinite-interval? ( obj -- ? )
  91     dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
  92
  93 : where-interval ( spec obj from/to -- )
  94     over first fp-infinity? [
  95         3drop
  96     ] [
  97         pick column-name>> 0%
  98         [ first2 ] dip interval-comparison 0%
  99         bind#
 100     ] if ;
 101
 102 : in-parens ( quot -- )
 103     "(" 0% call ")" 0% ; inline
 104
 105 M: interval where
 106     [
 107         [ from>> "from" where-interval ] [
 108             nip infinite-interval? [ " and " 0% ] unless
 109         ] [ to>> "to" where-interval ] 2tri
 110     ] in-parens ;
 111
 112 M: sequence where
 113     [
 114         [ " or " 0% ] [ dupd where ] interleave drop
 115     ] in-parens ;
 116
 117 M: byte-array where
 118     over column-name>> 0% " = " 0% bind# ;
 119
 120 M: NULL where
 121     drop column-name>> 0% " is NULL" 0% ;
 122
 123 : object-where ( spec obj -- )
 124     over column-name>> 0% " = " 0% bind# ;
 125
 126 M: object where object-where ;
 127
 128 M: integer where object-where ;
 129
 130 M: string where object-where ;
 131
 132 : filter-slots ( tuple specs -- specs' )
 133     [
 134         slot-name>> swap get-slot-named
 135         dup double-infinite-interval? [ drop f ] when
 136     ] with filter ;
 137
 138 : many-where ( tuple seq -- )
 139     " where " 0% [
 140         " and " 0%
 141     ] [
 142         2dup slot-name>> swap get-slot-named where
 143     ] interleave drop ;
 144
 145 : where-clause ( tuple specs -- )
 146     dupd filter-slots [ drop ] [ many-where ] if-empty ;
 147
 148 M: db-connection <delete-tuples-statement>
 149     [
 150         "delete from " 0% 0%
 151         where-clause
 152     ] query-make ;
 153
 154 ERROR: all-slots-ignored class ;
 155
 156 M: db-connection <select-by-slots-statement>
 157     [
 158         "select " 0%
 159         [ dupd filter-ignores ] dip
 160         over empty? [ all-slots-ignored ] when
 161         over
 162         [ ", " 0% ]
 163         [ dup column-name>> 0% 2, ] interleave
 164         " from " 0% 0%
 165         where-clause
 166     ] query-make ;
 167
 168 : do-group ( tuple groups -- )
 169     dup string? [ 1array ] when
 170     [ ", " join " group by " glue ] curry change-sql drop ;
 171
 172 : do-order ( tuple order -- )
 173     dup string? [ 1array ] when
 174     [ ", " join " order by " glue ] curry change-sql drop ;
 175
 176 : do-offset ( tuple n -- )
 177     [ number>string " offset " glue ] curry change-sql drop ;
 178
 179 : do-limit ( tuple n -- )
 180     [ number>string " limit " glue ] curry change-sql drop ;
 181
 182 : make-query* ( tuple query -- tuple' )
 183     dupd
 184     {
 185         [ group>> [ drop ] [ do-group ] if-empty ]
 186         [ order>> [ drop ] [ do-order ] if-empty ]
 187         [ limit>> [ do-limit ] [ drop ] if* ]
 188         [ offset>> [ do-offset ] [ drop ] if* ]
 189     } 2cleave ;
 190
 191 M: db-connection query>statement
 192     [ tuple>> dup class-of ] keep
 193     [ <select-by-slots-statement> ] dip make-query* ;
 194
 195 ! select ID, NAME, SCORE from EXAM limit 1 offset 3
 196
 197 M: db-connection <count-statement>
 198     [ tuple>> dup class-of ] keep
 199     [ [ "select count(*) from " 0% 0% where-clause ] query-make ]
 200     dip make-query* ;
 201
 202 : create-index ( index-name table-name columns -- )
 203     [
 204         [ [ "create index " % % ] dip " on " % % ] dip "(" %
 205         "," join % ")" %
 206     ] "" make sql-command ;
 207
 208 : ensure-index ( index-name table-name columns -- )
 209     '[ _ _ _ create-index ] ignore-index-exists ;
 210
 211 : drop-index ( index-name -- )
 212     [ "drop index " % % ] "" make sql-command ;
 213
 214 : create-database ( string -- )
 215     "create database " ";" surround sql-command ;
 216
 217 : ensure-database ( string -- )
 218     '[ _ create-database ] ignore-database-exists ;