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