basis/db/postgresql/postgresql.factor

   1 ! Copyright (C) 2007, 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs alien alien.syntax continuations io
   4 kernel math math.parser namespaces make prettyprint quotations
   5 sequences debugger db db.postgresql.lib db.postgresql.ffi
   6 db.tuples db.types tools.annotations math.ranges
   7 combinators classes classes.tuple locals words tools.walker
   8 db.private nmake accessors random db.queries destructors
   9 db.tuples.private db.postgresql db.errors.postgresql splitting ;
  10 IN: db.postgresql
  11
  12 TUPLE: postgresql-db host port pgopts pgtty database username password ;
  13
  14 : <postgresql-db> ( -- postgresql-db )
  15     postgresql-db new ;
  16
  17 <PRIVATE
  18
  19 TUPLE: postgresql-db-connection < db-connection ;
  20 : <postgresql-db-connection> ( handle -- db-connection )
  21     postgresql-db-connection new-db-connection
  22         swap >>handle ;
  23
  24 PRIVATE>
  25
  26 TUPLE: postgresql-statement < statement ;
  27
  28 TUPLE: postgresql-result-set < result-set ;
  29
  30 M: postgresql-db db-open ( db -- db-connection )
  31     {
  32         [ host>> ]
  33         [ port>> ]
  34         [ pgopts>> ]
  35         [ pgtty>> ]
  36         [ database>> ]
  37         [ username>> ]
  38         [ password>> ]
  39     } cleave connect-postgres <postgresql-db-connection> ;
  40
  41 M: postgresql-db-connection db-close ( handle -- ) PQfinish ;
  42
  43 M: postgresql-statement bind-statement* ( statement -- ) drop ;
  44
  45 GENERIC: postgresql-bind-conversion ( tuple object -- low-level-binding )
  46
  47 M: sql-spec postgresql-bind-conversion ( tuple spec -- object )
  48     slot-name>> swap get-slot-named <low-level-binding> ;
  49
  50 M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- object )
  51     nip value>> <low-level-binding> ;
  52
  53 M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
  54     dup generator-singleton>> eval-generator
  55     [ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
  56
  57 M: postgresql-statement bind-tuple ( tuple statement -- )
  58     [ nip ] [
  59         in-params>>
  60         [ postgresql-bind-conversion ] with map
  61     ] 2bi
  62     >>bind-params drop ;
  63
  64 M: postgresql-result-set #rows ( result-set -- n )
  65     handle>> PQntuples ;
  66
  67 M: postgresql-result-set #columns ( result-set -- n )
  68     handle>> PQnfields ;
  69
  70 : result-handle-n ( result-set -- handle n )
  71     [ handle>> ] [ n>> ] bi ;
  72
  73 M: postgresql-result-set row-column ( result-set column -- object )
  74     [ result-handle-n ] dip pq-get-string ;
  75
  76 M: postgresql-result-set row-column-typed ( result-set column -- object )
  77     dup pick out-params>> nth type>>
  78     [ result-handle-n ] 2dip postgresql-column-typed ;
  79
  80 M: postgresql-statement query-results ( query -- result-set )
  81     dup bind-params>> [
  82         over [ bind-statement ] keep
  83         do-postgresql-bound-statement
  84     ] [
  85         dup do-postgresql-statement
  86     ] if*
  87     postgresql-result-set new-result-set
  88     dup init-result-set ;
  89
  90 M: postgresql-result-set advance-row ( result-set -- )
  91     [ 1 + ] change-n drop ;
  92
  93 M: postgresql-result-set more-rows? ( result-set -- ? )
  94     [ n>> ] [ max>> ] bi < ;
  95
  96 M: postgresql-statement dispose ( query -- )
  97     dup handle>> PQclear
  98     f >>handle drop ;
  99
 100 M: postgresql-result-set dispose ( result-set -- )
 101     [ handle>> PQclear ]
 102     [
 103         0 >>n
 104         0 >>max
 105         f >>handle drop
 106     ] bi ;
 107
 108 M: postgresql-statement prepare-statement ( statement -- )
 109     dup
 110     [ db-connection get handle>> f ] dip
 111     [ sql>> ] [ in-params>> ] bi
 112     length f PQprepare postgresql-error
 113     >>handle drop ;
 114
 115 M: postgresql-db-connection <simple-statement> ( sql in out -- statement )
 116     postgresql-statement new-statement ;
 117
 118 M: postgresql-db-connection <prepared-statement> ( sql in out -- statement )
 119     <simple-statement> dup prepare-statement ;
 120
 121 : bind-name% ( -- )
 122     CHAR: $ 0,
 123     sql-counter [ inc ] [ get 0# ] bi ;
 124
 125 M: postgresql-db-connection bind% ( spec -- )
 126     bind-name% 1, ;
 127
 128 M: postgresql-db-connection bind# ( spec object -- )
 129     [ bind-name% f swap type>> ] dip
 130     <literal-bind> 1, ;
 131
 132 : create-table-sql ( class -- statement )
 133     [
 134         dupd
 135         "create table " 0% 0%
 136         "(" 0% [ ", " 0% ] [
 137             dup column-name>> 0%
 138             " " 0%
 139             dup type>> lookup-create-type 0%
 140             modifiers 0%
 141         ] interleave
 142
 143         ", " 0%
 144         find-primary-key
 145         "primary key(" 0%
 146         [ "," 0% ] [ column-name>> 0% ] interleave
 147         "));" 0%
 148     ] query-make ;
 149
 150 : create-function-sql ( class -- statement )
 151     [
 152         [ dup remove-id ] dip
 153         "create function add_" 0% dup 0%
 154         "(" 0%
 155         over [ "," 0% ]
 156         [
 157             type>> lookup-type 0%
 158         ] interleave
 159         ")" 0%
 160         " returns bigint as '" 0%
 161
 162         "insert into " 0%
 163         dup 0%
 164         "(" 0%
 165         over [ ", " 0% ] [ column-name>> 0% ] interleave
 166         ") values(" 0%
 167         swap [ ", " 0% ] [ drop bind-name% ] interleave
 168         "); " 0%
 169         "select currval(''" 0% 0% "_" 0%
 170         find-primary-key first column-name>> 0%
 171         "_seq'');' language sql;" 0%
 172     ] query-make ;
 173
 174 M: postgresql-db-connection create-sql-statement ( class -- seq )
 175     [
 176         [ create-table-sql , ] keep
 177         dup db-assigned? [ create-function-sql , ] [ drop ] if
 178     ] { } make ;
 179
 180 : drop-function-sql ( class -- statement )
 181     [
 182         "drop function add_" 0% 0%
 183         "(" 0%
 184         remove-id
 185         [ ", " 0% ] [ type>> lookup-type 0% ] interleave
 186         ");" 0%
 187     ] query-make ;
 188
 189 : drop-table-sql ( table -- statement )
 190     [
 191         "drop table " 0% 0% drop
 192     ] query-make ;
 193
 194 M: postgresql-db-connection drop-sql-statement ( class -- seq )
 195     [
 196         [ drop-table-sql , ] keep
 197         dup db-assigned? [ drop-function-sql , ] [ drop ] if
 198     ] { } make ;
 199
 200 M: postgresql-db-connection <insert-db-assigned-statement> ( class -- statement )
 201     [
 202         "select add_" 0% 0%
 203         "(" 0%
 204         dup find-primary-key first 2,
 205         remove-id
 206         [ ", " 0% ] [ bind% ] interleave
 207         ");" 0%
 208     ] query-make ;
 209
 210 M: postgresql-db-connection <insert-user-assigned-statement> ( class -- statement )
 211     [
 212         "insert into " 0% 0%
 213         "(" 0%
 214         dup [ ", " 0% ] [ column-name>> 0% ] interleave
 215         ")" 0%
 216
 217         " values(" 0%
 218         [ ", " 0% ] [
 219             dup type>> +random-id+ = [
 220                 [
 221                     bind-name%
 222                     slot-name>>
 223                     f
 224                     random-id-generator
 225                 ] [ type>> ] bi <generator-bind> 1,
 226             ] [
 227                 bind%
 228             ] if
 229         ] interleave
 230         ");" 0%
 231     ] query-make ;
 232
 233 M: postgresql-db-connection insert-tuple-set-key ( tuple statement -- )
 234     query-modify-tuple ;
 235
 236 M: postgresql-db-connection persistent-table ( -- hashtable )
 237     H{
 238         { +db-assigned-id+ { "integer" "serial" f } }
 239         { +user-assigned-id+ { f f f } }
 240         { +random-id+ { "bigint" "bigint" f } }
 241
 242         { +foreign-id+ { f f "references" } }
 243
 244         { +on-update+ { f f "on update" } }
 245         { +on-delete+ { f f "on delete" } }
 246         { +restrict+ { f f "restrict" } }
 247         { +cascade+ { f f "cascade" } }
 248         { +set-null+ { f f "set null" } }
 249         { +set-default+ { f f "set default" } }
 250
 251         { TEXT { "text" "text" f } }
 252         { VARCHAR { "varchar" "varchar" f } }
 253         { INTEGER { "integer" "integer" f } }
 254         { BIG-INTEGER { "bigint" "bigint" f } }
 255         { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 256         { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 257         { DOUBLE { "real" "real" f } }
 258         { DATE { "date" "date" f } }
 259         { TIME { "time" "time" f } }
 260         { DATETIME { "timestamp" "timestamp" f } }
 261         { TIMESTAMP { "timestamp" "timestamp" f } }
 262         { BLOB { "bytea" "bytea" f } }
 263         { FACTOR-BLOB { "bytea" "bytea" f } }
 264         { URL { "varchar" "varchar" f } }
 265         { +autoincrement+ { f f "autoincrement" } }
 266         { +unique+ { f f "unique" } }
 267         { +default+ { f f "default" } }
 268         { +null+ { f f "null" } }
 269         { +not-null+ { f f "not null" } }
 270         { system-random-generator { f f f } }
 271         { secure-random-generator { f f f } }
 272         { random-generator { f f f } }
 273     } ;
 274
 275 ERROR: no-compound-found string object ;
 276 M: postgresql-db-connection compound ( string object -- string' )
 277     over {
 278         { "default" [ first number>string " " glue ] }
 279         { "varchar" [ first number>string "(" ")" surround append ] }
 280         { "references" [ >reference-string ] }
 281         [ drop no-compound-found ]
 282     } case ;
 283
 284 M: postgresql-db-connection parse-db-error
 285     "\n" split dup length {
 286         { 1 [ first parse-postgresql-sql-error ] }
 287         { 2 [ concat parse-postgresql-sql-error ] }
 288         { 3 [
 289                 first3
 290                 [ parse-postgresql-sql-error ] 2dip
 291                 postgresql-location >>location
 292         ] }
 293     } case ;