trunk/R/db.R

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