enable: ggplot2 and rapport package AND adding masked options fns

Enabling rapport resulted in tweaking `options` and `getOptions` to let server owners to specify which options could be modified (and listed). To do so set `sandboxR.disabled.options` option to a character vector of unwanted options.

DESCRIPTION

@@ -19,3 +19,4 @@ Collate:
     'sandbox.R'
     'sandboxR.R'
     'blacklist.R'
+    'init.R'

R/blacklist.R

@@ -29,12 +29,14 @@ commands.blacklist <- function(pkg) {
                       grDevices = c('bitmap', 'bmp', 'cairo_pdf', 'cairo_ps', 'CIDFont', 'dev2bitmap', 'devAskNewPage', 'dev.capabilities', 'dev.capture', 'dev.control', 'dev.copy', 'dev.copy2eps', 'dev.copy2pdf', 'dev.cur', 'dev.flush', 'dev.hold', 'deviceIsInteractive', 'dev.interactive', 'dev.list', 'dev.new', 'dev.next', 'dev.off', 'dev.prev', 'dev.print', 'dev.set', 'dev.size', 'embedFonts', 'getGraphicsEvent', 'getGraphicsEventEnv', 'graphics.off', 'jpeg', 'pdf', 'pdfFonts', 'pdf.options', 'pictex', 'png', 'postscript', 'postscriptFont', 'postscriptFonts', 'ps.options', 'quartz', 'quartzFont', 'quartzFonts', 'quartz.options', 'recordGraphics', 'recordPlot', 'replayPlot', 'savePlot', 'setEPS', 'setGraphicsEventEnv', 'setGraphicsEventHandlers', 'setPS', 'svg', 'tiff', 'Type1Font', 'x11', 'X11', 'X11Font', 'X11Fonts', 'X11.options', 'xfig'),
                       methods = c('addNextMethod', 'allGenerics', 'allNames', 'asMethodDefinition', 'assignClassDef', 'assignMethodsMetaData', 'balanceMethodsList', 'cacheGenericsMetaData', 'cacheMetaData', 'cacheMethod', 'callGeneric', 'callNextMethod', 'canCoerce', 'checkSlotAssignment', '.classEnv', 'classesToAM', 'classLabel', 'classMetaName', 'className', 'completeClassDefinition', 'completeExtends', 'completeSubclasses', 'conformMethod', 'defaultDumpName', 'defaultPrototype', 'doPrimitiveMethod', '.doTracePrint', 'dumpMethod', 'dumpMethods', 'el', 'elNamed', 'empty.dump', 'emptyMethodsList', 'evalOnLoad', 'evalqOnLoad', 'evalSource', 'existsFunction', 'existsMethod', 'finalDefaultMethod', 'findClass', 'findFunction', 'findMethod', 'findMethods', 'findMethodSignatures', 'findUnique', 'fixPre1.8', 'formalArgs', 'functionBody', 'generic.skeleton', 'getAccess', 'getAllMethods', 'getAllSuperClasses', 'getClass', 'getClassDef', 'getClasses', 'getClassName', 'getClassPackage', 'getDataPart', 'getExtends', 'getFunction', 'getGeneric', 'getGenerics', 'getGroup', 'getGroupMembers', 'getLoadActions', 'getMethod', 'getMethods', 'getMethodsForDispatch', 'getMethodsMetaData', 'getPackageName', 'getProperties', 'getPrototype', 'getRefClass', 'getSlots', 'getSubclasses', 'getValidity', 'getVirtual', 'hasArg', 'hasLoadAction', 'hasMethod', 'hasMethods', '.hasSlot', 'implicitGeneric', 'inheritedSlotNames', 'initFieldArgs', 'initialize', 'initRefFields', 'insertMethod', 'insertSource', 'isClass', 'isClassDef', 'isClassUnion', 'isGeneric', 'isGrammarSymbol', 'isGroup', 'isSealedClass', 'isSealedMethod', 'isVirtualClass', 'isXS3Class', 'languageEl', '.Last.lib', 'linearizeMlist', 'listFromMethods', 'listFromMlist', 'loadMethod', 'Logic', 'makeClassRepresentation', 'makeExtends', 'makeGeneric', 'makeMethodsList', 'makePrototypeFromClassDef', 'makeStandardGeneric', 'matchSignature', 'mergeMethods', 'metaNameUndo', 'MethodAddCoerce', 'methodSignatureMatrix', 'method.skeleton', 'MethodsList', 'MethodsListSelect', 'methodsPackageMetaName', 'missingArg', 'mlistMetaName', 'multipleClasses', 'new', 'newBasic', 'newClassRepresentation', 'newEmptyObject', 'new.env', 'new.packages', 'Ops', 'Ops.data.frame', 'Ops.Date', 'Ops.difftime', 'Ops.factor', 'Ops.numeric_version', 'Ops.ordered', 'Ops.POSIXt', 'Ops.raster', 'Ops.ts', 'packageSlot', 'possibleExtends', 'prohibitGeneric', 'promptClass', 'promptMethods', 'prototype', 'Quote', 'reconcilePropertiesAndPrototype', 'registerImplicitGenerics', 'rematchDefinition', 'removeClass', 'removeGeneric', 'removeMethod', 'removeMethods', 'removeMethodsObject', 'representation', 'requireMethods', 'resetClass', 'resetGeneric', 'S3Class', 'S3Part', 'sealClass', 'seemsS4Object', 'selectMethod', 'selectSuperClasses', '.selectSuperClasses', 'sessionData', 'setAs', 'setClass', 'setClassUnion', 'setDataPart', 'setGeneric', 'setGenericImplicit', 'setGroupGeneric', 'setIs', 'setLoadAction', 'setLoadActions', 'setMethod', 'setOldClass', 'setPackageName', 'setPrimitiveMethods', 'setRefClass', 'setReplaceMethod', 'setValidity', 'showClass', 'showDefault', 'showExtends', 'showMethods', 'showMlist', 'signature', 'SignatureMethod', 'sigToEnv', 'slot', 'slotNames', '.slotNames', 'slotsFromS3', 'substituteDirect', 'substituteFunctionArgs', 'superClassDepth', 'testInheritedMethods', 'testVirtual', 'traceOff', 'traceOn', '.TraceWithMethods', 'tryNew', 'trySilent', 'unRematchDefinition', '.untracedFunction', 'validObject', 'validSlotNames', '.valueClassTest'),
                       datasets = NULL,
-                      grid = c('draw.details', 'drawDetails', 'drawDetails.recordedGrob', 'grid.record', 'postDrawDetails', 'preDrawDetails', 'recordGrob'),
-                      lattice = c('trellis.device', 'checkArgsAndCall'),
+                      grid     = c('draw.details', 'drawDetails', 'drawDetails.recordedGrob', 'grid.record', 'postDrawDetails', 'preDrawDetails', 'recordGrob'),
+                      lattice  = c('trellis.device', 'checkArgsAndCall'),
                       KernSmooth = NULL,
-                      nortest = NULL,
-                      descr = c('file.head', 'fwf2csv'),
-                      outliers = NULL)
+                      nortest  = NULL,
+                      descr    = c('file.head', 'fwf2csv'),
+                      outliers = NULL,
+                      ggplot2  = c('ggsave', 'safe.call'),
+                      rapport  = c('decrypt', 'encrypt', 'eval.msgs', 'evals', 'get.tags', 'grab.chunks', 'has.tags', 'purge.comments', 'rapport.html', 'rapport.odt', 'redraw.recordedplot', 'tpl.check', 'tpl.example', 'tpl.export', 'tpl.info', 'tpl.inputs', 'tpl.list', 'tpl.meta', 'tpl.paths', 'tpl.paths.add', 'tpl.paths.remove', 'tpl.paths.reset', 'tpl.rerun', 'tpl.tangle'))
 
     if (missing(pkg))
         pkg <- names(blacklist)

R/masked.functions.R

@@ -117,3 +117,51 @@ formula.character <- function(x, env = parent.frame(), ...)
 
 latticeParseFormula <- lattice:::latticeParseFormula
 body(latticeParseFormula) <- as.call(c(as.symbol("{"), c(substitute(if (inherits(groups, "formula")) sandbox.pretest(as.character(groups)[2])), as.list(body(latticeParseFormula))[-1])))
+
+
+rapport <- function(...) {
+
+    mc <- match.call(rapport::rapport)
+
+    if (!is.null(mc$reproducible) | !is.null(mc$env) | !is.null(mc$header.levels.offset) | !is.null(mc$rapport.mode) | !is.null(mc$graph.output) | !is.null(mc$file.name) | !is.null(mc$file.path) | !is.null(mc$graph.replay) | !is.null(mc$graph.hi.res))
+        stop('Forbidden parameters provided!')
+
+    mc[[1]] <- quote(rapport::rapport)
+    res <- base::eval(mc)
+
+    return(invisible(res))
+
+}
+
+
+options <- function(...) {
+
+    l <- names(list(...))
+
+    disabled.options <- base::getOption('sandboxR.disabled.options')
+
+    if (length(l) == 0) {
+        o <- base::options()
+        return(o[setdiff(names(o), disabled.options)])
+    }
+
+    if (any(l %in% disabled.options))
+        stop('Not available option(s) queried.')
+
+    mc <- match.call()
+    mc[[1]] <- quote(base::options)
+    res <- base::eval(mc)
+
+    return(invisible(res))
+
+}
+
+
+getOption <- function(x, default = NULL) {
+
+    if (x %in% base::getOption('sandboxR.disabled.options'))
+        stop('Not available option(s) queried.')
+
+    return(base::getOption(x, default))
+
+}

R/sandbox.R

@@ -8,6 +8,8 @@
 #' @export
 sandbox.env <- function(blacklist = as.character(unlist(commands.blacklist()))) {
 
+    ## TODO: check if sandboxed env was created before and return that instead of regenerating
+
     ## prepare a custom environment with dummy functions
     sandboxed.env <- new.env()
     for (cmd in blacklist) {

TODO.md

@@ -1,19 +1,23 @@
 # Major tasks
 
  * ~~Redesign sandboxR to run in an environment with dummy forbidden functions loaded.~~
- * _Tidy up unnecessary regexps and checks from `sandbox` thanks to the above!_
+ * ~~Tidy up unnecessary regexps and checks from `sandbox` thanks to the above!~~
 
-# Allow and create masked functions for the followings
+# Check up at least twice!
+
+ * masked fn of `latticeParseFormula` is really needed? sandboxR environment seems to handle malicious calls hidden inside without updating that in `lattice` namespace
+
+# Allow (and create) masked functions for the followings
 
 ## Base
 
  * ~~get~~, mget
  * ~~assign~~
  * ~~ls~~
  * attach, detach (_wontfix_)
- * chartr (_can be done even now by removing masked `paste`, `sprintf` etc._), rawToChar (etc.)
  * parse, deparse
  * ~~eval~~
+ * do.call (safe.call from ggplot2) etc.
  * exists
  * is.call, as.call, call
  * ~~library, require~~
@@ -42,15 +46,14 @@ All functions to be revised (nothing permitted ATM).
 
 # Further packages to permit (backlist)
 
- * grid
- * lattice
+ * ~~grid~~
+ * ~~lattice~~
  * parralel (_wontfix_ for RApache environment ATM)
  * reshape, reshape2, plyr
- * ggplot2
+ * ~~ggplot2~~
  * wordcloud, treemap, scatterplot3d etc.
- * nortest
- * outliers
- * descr
- * rapport 
+ * ~~nortest~~
+ * ~~outliers~~
+ * ~~descr~~
+ * ~~rapport~~
  * ...
-

inst/tests/sandbox.R

@@ -84,15 +84,27 @@ test_that('ls', {
 
 test_that('library/require', {
     expect_output(sandbox('library()'), '.*')
-    expect_output(sandbox('library(base)'), '.*')
-    expect_output(sandbox('library(base, verbose = TRUE)'), '.*')
-    expect_output(sandbox('library("base")'), '.*')
+    expect_output(sandbox('library(stats)'), '.*')
+    expect_output(sandbox('suppressWarnings(library(stats, verbose = TRUE))'), '.*')
+    expect_output(sandbox('library("stats")'), '.*')
     expect_error(sandbox('library(RCurl)'))
     expect_error(sandbox('library("RCurl")'))
     expect_output(sandbox('require(stats)'), '.*')
     expect_error(sandbox('require(RCurl)'))
 })
 
+context('options')
+
+test_that('allowed options', {
+    expect_output(sandbox('options(test=10)'), '.*')
+    expect_output(sandbox('getOption("test")'), '10')
+})
+
+test_that('allowed options', {
+    expect_error(sandbox('options(sandboxR.disabled.options=10)'), '.*')
+    expect_error(sandbox('getOption("sandboxR.disabled.options")'))
+})
+
 context('modified internals')
 
 test_that('lm hacks', {
@@ -111,5 +123,5 @@ test_that('lm hacks', {
 
 
 test_that('latticeParseFormula', {
-    expect_error(sandbox(c('x <- c(\'1\', \'readLines("/etc/passwd")\'', "class(x) <- 'formula'", "latticeParseFormula(data=mtcars, model=hp~wt, groups=x)")))
+    expect_error(sandbox(c('x <- c(\'1\', \'readLines("/etc/passwd")\')', "class(x) <- 'formula'", "latticeParseFormula(data=mtcars, model=hp~wt, groups=x)")))
 })