tags/pre-dual/R/db.R

   1
   2 db_start <- function() {
   3     drv <- dbDriver('SQLite')
   4     con <- dbConnect(drv, dbname=file.path(cache_root,'cran2deb.db'))
   5     if (!dbExistsTable(con,'sysreq_override')) {
   6         dbGetQuery(con,paste('CREATE TABLE sysreq_override ('
   7                   ,' depend_alias TEXT NOT NULL'
   8                   ,',r_pattern TEXT PRIMARY KEY NOT NULL'
   9                   ,')'))
  10     }
  11     if (!dbExistsTable(con,'debian_dependency')) {
  12         dbGetQuery(con,paste('CREATE TABLE debian_dependency ('
  13                   ,' id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL'
  14                   ,',alias TEXT NOT NULL'
  15                   ,',build INTEGER NOT NULL'
  16                   ,',debian_pkg TEXT NOT NULL'
  17                   ,',UNIQUE (alias,build,debian_pkg)'
  18                   ,')'))
  19     }
  20     if (!dbExistsTable(con,'forced_depends')) {
  21         dbGetQuery(con,paste('CREATE TABLE forced_depends ('
  22                   ,' r_name TEXT NOT NULL'
  23                   ,',depend_alias TEXT NOT NULL'
  24                   ,',PRIMARY KEY (r_name,depend_alias)'
  25                   ,')'))
  26     }
  27     if (!dbExistsTable(con,'license_override')) {
  28         dbGetQuery(con,paste('CREATE TABLE license_override ('
  29                   ,' name TEXT PRIMARY KEY NOT NULL'
  30                   ,',accept INT NOT NULL'
  31                   ,')'))
  32     }
  33     if (!dbExistsTable(con,'license_hashes')) {
  34         dbGetQuery(con,paste('CREATE TABLE license_hashes ('
  35                   ,' name TEXT NOT NULL'
  36                   ,',sha1 TEXT PRIMARY KEY NOT NULL'
  37                   ,')'))
  38     }
  39     if (!dbExistsTable(con,'database_versions')) {
  40         dbGetQuery(con,paste('CREATE TABLE database_versions ('
  41                   ,' version INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL'
  42                   ,',version_date INTEGER NOT NULL'
  43                   ,',base_epoch INTEGER NOT NULL'
  44                   ,')'))
  45         db_add_version(con,1,0)
  46     }
  47     if (!dbExistsTable(con,'packages')) {
  48         dbGetQuery(con,paste('CREATE TABLE packages ('
  49                   ,' package TEXT PRIMARY KEY NOT NULL'
  50                   ,',latest_r_version TEXT'
  51                   ,')'))
  52     }
  53     if (!dbExistsTable(con,'builds')) {
  54         dbGetQuery(con,paste('CREATE TABLE builds ('
  55                   ,' id INTEGER PRIMARY KEY AUTOINCREMENT NOT NULL'
  56                   ,',system TEXT NOT NULL'
  57                   ,',package TEXT NOT NULL'
  58                   ,',r_version TEXT NOT NULL'
  59                   ,',deb_epoch INTEGER NOT NULL'
  60                   ,',deb_revision INTEGER NOT NULL'
  61                   ,',db_version INTEGER NOT NULL'
  62                   ,',date_stamp TEXT NOT NULL'
  63                   ,',time_stamp TEXT NOT NULL'
  64                   ,',scm_revision TEXT NOT NULL'
  65                   ,',success INTEGER NOT NULL'
  66                   ,',log TEXT'
  67                   ,',UNIQUE(package,system,r_version,deb_epoch,deb_revision,db_version)'
  68                   ,')'))
  69     }
  70     if (!dbExistsTable(con,'blacklist_packages')) {
  71         dbGetQuery(con,paste('CREATE TABLE blacklist_packages ('
  72                   ,' package TEXT PRIMARY KEY NOT NULL '
  73                   ,',nonfree INTEGER NOT NULL DEFAULT 0'
  74                   ,',obsolete INTEGER NOT NULL DEFAULT 0'
  75                   ,',broken_dependency INTEGER NOT NULL DEFAULT 0'
  76                   ,',unsatisfied_dependency INTEGER NOT NULL DEFAULT 0'
  77                   ,',breaks_cran2deb INTEGER NOT NULL DEFAULT 0'
  78                   ,',other INTEGER NOT NULL DEFAULT 0'
  79                   ,',explanation TEXT NOT NULL '
  80                   ,')'))
  81     }
  82     return(con)
  83 }
  84
  85 db_stop <- function(con,bump=F) {
  86     if (bump) {
  87         db_bump(con)
  88     }
  89     dbDisconnect(con)
  90 }
  91
  92 db_quote <- function(text) {
  93     return(paste('\'', gsub('([\'"])','\\1\\1',text),'\'',sep=''))
  94 }
  95
  96 db_now <- function() {
  97     return(as.integer(gsub('-','',Sys.Date())))
  98 }
  99
 100 db_cur_version <- function(con) {
 101     return(as.integer(dbGetQuery(con, 'SELECT max(version) FROM database_versions')[[1]]))
 102 }
 103
 104 db_base_epoch <- function(con) {
 105     return(as.integer(dbGetQuery(con,
 106         paste('SELECT max(base_epoch) FROM database_versions'
 107              ,'WHERE version IN (SELECT max(version) FROM database_versions)'))[[1]]))
 108 }
 109
 110 db_get_base_epoch <- function() {
 111     con <- db_start()
 112     v <- db_base_epoch(con)
 113     db_stop(con)
 114     return(v)
 115 }
 116
 117 db_get_version <- function() {
 118     con <- db_start()
 119     v <- db_cur_version(con)
 120     db_stop(con)
 121     return(v)
 122 }
 123
 124 db_add_version <- function(con, version, epoch) {
 125     dbGetQuery(con,paste('INSERT INTO database_versions (version,version_date,base_epoch)'
 126               ,'VALUES (',as.integer(version),',',db_now(),',',as.integer(epoch),')'))
 127 }
 128
 129 db_bump <- function(con) {
 130     db_add_version(con,db_cur_version(con)+1, db_base_epoch(con))
 131 }
 132
 133 db_bump_epoch <- function(con) {
 134     db_add_version(con,db_cur_version(con)+1, db_base_epoch(con)+1)
 135 }
 136
 137 db_sysreq_override <- function(sysreq_text) {
 138     con <- db_start()
 139     results <- dbGetQuery(con,paste(
 140                     'SELECT DISTINCT depend_alias FROM sysreq_override WHERE'
 141                             ,db_quote(tolower(sysreq_text)),'LIKE r_pattern'))
 142     db_stop(con)
 143     if (length(results) == 0) {
 144         return(NULL)
 145     }
 146     return(results$depend_alias)
 147 }
 148
 149 db_add_sysreq_override <- function(pattern,depend_alias) {
 150     con <- db_start()
 151     results <- dbGetQuery(con,paste(
 152                      'INSERT OR REPLACE INTO sysreq_override'
 153                     ,'(depend_alias, r_pattern) VALUES ('
 154                     ,' ',db_quote(tolower(depend_alias))
 155                     ,',',db_quote(tolower(pattern))
 156                     ,')'))
 157     db_stop(con)
 158 }
 159
 160 db_sysreq_overrides <- function() {
 161     con <- db_start()
 162     overrides <- dbGetQuery(con,paste('SELECT * FROM sysreq_override'))
 163     db_stop(con)
 164     return(overrides)
 165 }
 166
 167 db_get_depends <- function(depend_alias,build=F) {
 168     con <- db_start()
 169     results <- dbGetQuery(con,paste(
 170                     'SELECT DISTINCT debian_pkg FROM debian_dependency WHERE'
 171                     ,db_quote(tolower(depend_alias)),'= alias'
 172                     ,'AND',as.integer(build),'= build'))
 173     db_stop(con)
 174     return(results$debian_pkg)
 175 }
 176
 177 db_add_depends <- function(depend_alias,debian_pkg,build=F) {
 178     con <- db_start()
 179     results <- dbGetQuery(con,paste(
 180                      'INSERT OR REPLACE INTO debian_dependency'
 181                     ,'(alias, build, debian_pkg) VALUES ('
 182                     ,' ',db_quote(tolower(depend_alias))
 183                     ,',',as.integer(build)
 184                     ,',',db_quote(tolower(debian_pkg))
 185                     ,')'))
 186     db_stop(con)
 187 }
 188
 189 db_depends <- function() {
 190     con <- db_start()
 191     depends <- dbGetQuery(con,paste('SELECT * FROM debian_dependency'))
 192     db_stop(con)
 193     return(depends)
 194 }
 195
 196 db_get_forced_depends <- function(r_name) {
 197     con <- db_start()
 198     forced_depends <- dbGetQuery(con,
 199                 paste('SELECT depend_alias FROM forced_depends WHERE'
 200                      ,db_quote(r_name),'= r_name'))
 201     db_stop(con)
 202     return(forced_depends$depend_alias)
 203 }
 204
 205 db_add_forced_depends <- function(r_name, depend_alias) {
 206     if (!length(db_get_depends(depend_alias,build=F)) &&
 207         !length(db_get_depends(depend_alias,build=T))) {
 208         fail('Debian dependency alias',depend_alias,'is not know,'
 209                   ,'yet trying to force a dependency on it?')
 210     }
 211     con <- db_start()
 212     dbGetQuery(con,
 213             paste('INSERT OR REPLACE INTO forced_depends (r_name, depend_alias)'
 214                  ,'VALUES (',db_quote(r_name),',',db_quote(depend_alias),')'))
 215     db_stop(con)
 216 }
 217
 218 db_forced_depends <- function() {
 219     con <- db_start()
 220     depends <- dbGetQuery(con,paste('SELECT * FROM forced_depends'))
 221     db_stop(con)
 222     return(depends)
 223 }
 224
 225 db_license_override_name <- function(name) {
 226     con <- db_start()
 227     results <- dbGetQuery(con,paste(
 228                     'SELECT DISTINCT accept FROM license_override WHERE'
 229                             ,db_quote(tolower(name)),'= name'))
 230     db_stop(con)
 231     if (length(results) == 0) {
 232         return(NULL)
 233     }
 234     return(as.logical(results$accept))
 235 }
 236
 237 db_add_license_override <- function(name,accept) {
 238     notice('adding',name,'accept?',accept)
 239     if (accept != TRUE && accept != FALSE) {
 240         fail('accept must be TRUE or FALSE')
 241     }
 242     con <- db_start()
 243     results <- dbGetQuery(con,paste(
 244                      'INSERT OR REPLACE INTO license_override'
 245                     ,'(name, accept) VALUES ('
 246                     ,' ',db_quote(tolower(name))
 247                     ,',',as.integer(accept)
 248                     ,')'))
 249     db_stop(con)
 250 }
 251
 252 db_license_override_hash <- function(license_sha1) {
 253     con <- db_start()
 254     results <- dbGetQuery(con,paste(
 255                      'SELECT DISTINCT accept FROM license_override'
 256                     ,'INNER JOIN license_hashes'
 257                     ,'ON license_hashes.name = license_override.name WHERE'
 258                     ,db_quote(tolower(license_sha1)),'= license_hashes.sha1'))
 259     db_stop(con)
 260     if (length(results) == 0) {
 261         return(NULL)
 262     }
 263     return(as.logical(results$accept))
 264 }
 265
 266 db_license_overrides <- function() {
 267     con <- db_start()
 268     overrides <- dbGetQuery(con,paste('SELECT * FROM license_override'))
 269     hashes    <- dbGetQuery(con,paste('SELECT * FROM license_hashes'))
 270     db_stop(con)
 271     return(list(overrides=overrides,hashes=hashes))
 272 }
 273
 274 db_add_license_hash <- function(name,license_sha1) {
 275     if (is.null(db_license_override_name(name))) {
 276         fail('license',name,'is not know, yet trying to add a hash for it?')
 277     }
 278     notice('adding hash',license_sha1,'for',name)
 279     con <- db_start()
 280     dbGetQuery(con,paste(
 281          'INSERT OR REPLACE INTO license_hashes'
 282         ,'(name, sha1) VALUES ('
 283         ,' ',db_quote(tolower(name))
 284         ,',',db_quote(tolower(license_sha1))
 285         ,')'))
 286     db_stop(con)
 287 }
 288
 289
 290 db_update_package_versions <- function() {
 291     # seems like the quickest way of doing this:
 292     con <- db_start()
 293     dbGetQuery(con, 'DROP TABLE packages')
 294     db_stop(con)
 295     # db_start re-makes all tables
 296     con <- db_start()
 297     for (package in available[,'Package']) {
 298         dbGetQuery(con, paste('INSERT OR REPLACE INTO packages (package,latest_r_version)'
 299                              ,'VALUES (',db_quote(package)
 300                              ,',',db_quote(available[package,'Version']),')'))
 301     }
 302     dbGetQuery(con,'DELETE FROM builds WHERE builds.package NOT IN (SELECT package FROM packages)')
 303     db_stop(con)
 304 }
 305
 306 db_date_format <- '%Y-%m-%d'
 307 db_time_format <- '%H:%M:%OS'
 308
 309 db_record_build <- function(package, deb_version, log, success=F) {
 310     # if the log is more than 1kB, only keep the last 1kB.
 311     # this is to work around a problem that seems to have appeared in R 2.10 causing calloc errors.
 312     # if the log is not pruned then we get the following error:
 313     #
 314     # Error in gsub("(['\"])", "\\1\\1", text) :
 315     #   Calloc could not allocate (-197080581 of 1) memory
 316     # Error in dbGetQuery(con, paste("INSERT OR REPLACE INTO builds", "(package,system,r_version,deb_epoch,deb_revision,db_version,success,date_stamp,time_stamp,scm_revision,log)",  :
 317     #   error in evaluating the argument 'statement' in selecting a method for function 'dbGetQuery'
 318
 319     log <- paste(log,collapse='\n')
 320     end <- nchar(log)
 321     max_log_len <- 10240
 322     if (end > max_log_len) {
 323         log <- db_quote(substr(log,end-max_log_len,end))
 324     } else {
 325         log <- db_quote(log)
 326     }
 327     con <- db_start()
 328     o <- options(digits.secs = 6)
 329     sqlcmd <- paste('INSERT OR REPLACE INTO builds'
 330                     ,'(package,system,r_version,deb_epoch,deb_revision,db_version,success,date_stamp,time_stamp,scm_revision,log)'
 331                     ,'VALUES'
 332                     ,'(',db_quote(package)
 333                     ,',',db_quote(which_system)
 334                     ,',',db_quote(version_upstream(deb_version))
 335                     ,',',db_quote(version_epoch(deb_version))
 336                     ,',',db_quote(version_revision(deb_version))
 337                     ,',',db_cur_version(con)
 338                     ,',',as.integer(success)
 339                     ,',',db_quote(format(Sys.time(), db_date_format))
 340                     ,',',db_quote(format(Sys.time(), db_time_format))
 341                     ,',',db_quote(scm_revision)
 342                     ,',',log
 343                     ,')')
 344     ##print(sqlcmd)
 345     try(dbGetQuery(con,sqlcmd))
 346     options(o)
 347     db_stop(con)
 348 }
 349
 350 db_builds <- function(pkgname) {
 351     # returns all successful builds
 352     con <- db_start()
 353     build <- dbGetQuery(con, paste('SELECT * FROM builds'
 354                        ,'WHERE success = 1'
 355                        ,'AND system =',db_quote(which_system)
 356                        ,'AND package =',db_quote(pkgname)))
 357     db_stop(con)
 358     if (length(build) == 0) {
 359         return(NULL)
 360     }
 361     return(db_cleanup_builds(build))
 362 }
 363
 364 db_cleanup_builds <- function(build) {
 365     build$success <- as.logical(build$success)
 366     #o <-options(digits.secs = 6)
 367     dt <- as.POSIXct(strptime(paste(as.character(build[,"date_stamp"]), as.character(build[,"time_stamp"])),
 368                               paste(db_date_format, db_time_format)))
 369     build$time_stamp <- NULL
 370     build$date_stamp <- NULL
 371     newdf <- data.frame(build, date_stamp=dt)
 372     #print(newdf[, -grep("log", colnames(newdf))])
 373     #options(o)
 374     #print(newdf[, -grep("log", colnames(newdf))])
 375     return(newdf)
 376 }
 377
 378 db_latest_build <- function(pkgname) {
 379     con <- db_start()
 380     build <- dbGetQuery(con, paste('SELECT * FROM builds'
 381                        ,'NATURAL JOIN (SELECT package,max(id) AS max_id FROM builds'
 382                        ,              'WHERE system =',db_quote(which_system)
 383                        ,              'GROUP BY package) AS last'
 384                        ,'WHERE id = max_id'
 385                        ,'AND builds.package =',db_quote(pkgname)))
 386     db_stop(con)
 387     if (length(build) == 0) {
 388         return(NULL)
 389     }
 390     return(db_cleanup_builds(build))
 391 }
 392
 393 db_latest_build_version <- function(pkgname) {
 394     build <- db_latest_build(pkgname)
 395     if (is.null(build)) {
 396         return(NULL)
 397     }
 398     return(version_new(build$r_version, build$deb_revision, build$deb_epoch))
 399 }
 400
 401 db_latest_build_status <- function(pkgname) {
 402     build <- db_latest_build(pkgname)
 403     if (is.null(build)) {
 404         return(NULL)
 405     }
 406     return(list(build$success,build$log))
 407 }
 408
 409 db_outdated_packages <- function() {
 410     con <- db_start()
 411     packages <- dbGetQuery(con,paste('SELECT packages.package FROM packages'
 412                ,'LEFT OUTER JOIN ('
 413                # extract the latest attempt at building each package
 414                ,      'SELECT * FROM builds'
 415                ,      'NATURAL JOIN (SELECT package,max(id) AS max_id FROM builds'
 416                ,                    'WHERE system =',db_quote(which_system)
 417                ,                    'GROUP BY package) AS last'
 418                ,      'WHERE id = max_id) AS build'
 419                ,'ON build.package = packages.package'
 420                # outdated iff:
 421                # - there is no latest build
 422                ,'WHERE build.package IS NULL'
 423                # - the database has changed since last build
 424                ,'OR build.db_version < (SELECT max(version) FROM database_versions)'
 425                # - the debian epoch has been bumped up
 426                ,'OR build.deb_epoch < (SELECT max(base_epoch) FROM database_versions'
 427                ,                        'WHERE version IN ('
 428                ,                            'SELECT max(version) FROM database_versions))'
 429                # - the latest build is not of the latest R version
 430                ,'OR build.r_version != packages.latest_r_version'
 431                ))$package
 432     db_stop(con)
 433     return(packages)
 434 }
 435
 436 db_blacklist_packages <- function() {
 437     con <- db_start()
 438     packages <- dbGetQuery(con,'SELECT package from blacklist_packages')$package
 439     db_stop(con)
 440     return(packages)
 441 }
 442
 443 db_blacklist_reasons <- function () {
 444     con <- db_start()
 445     packages <- dbGetQuery(con,'SELECT package,explanation from blacklist_packages group by explanation')
 446     db_stop(con)
 447     return(packages)
 448 }
 449
 450 db_todays_builds <- function() {
 451     today <- db_quote(format(Sys.time(), db_date_format))
 452     con <- db_start()
 453     builds <- dbGetQuery(con,paste('select id,success,system,package,
 454                                     r_version as version,deb_epoch as epo,
 455                                     deb_revision as rev, scm_revision as svnrev,
 456                                     db_version as db,date_stamp,time_stamp
 457                                     from builds where date_stamp = ',today))
 458     db_stop(con)
 459     return(builds)
 460 }
 461
 462 db_successful_builds <- function() {
 463     con <- db_start()
 464     builds <- dbGetQuery(con,'select system,package,r_version,date_stamp,time_stamp
 465                               from builds natural join (select system,package,max(id) as id
 466                                                         from builds
 467                                                         where package not in
 468                                                                 (select package from blacklist_packages)
 469                                                         group by package,system)
 470                               where success = 1')
 471     db_stop(con)
 472     return(builds)
 473 }
 474
 475 db_failed_builds <- function() {
 476     con <- db_start()
 477     builds <- dbGetQuery(con,'select system,package,r_version,date_stamp,time_stamp
 478                               from builds natural join (select system,package,max(id) as id
 479                                                         from builds
 480                                                         where package not in
 481                                                                 (select package from blacklist_packages)
 482                                                         group by package,system)
 483                               where success = 0')
 484     db_stop(con)
 485     return(builds)
 486 }