trunk/R/db.R

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