basis/db/queries/queries.factor

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