R/virtualbox.R

In vmr: Virtual Machines for R

# This file is part of vmr.
# Copyright (c) 2021 Jean-François Rey <jf.rey.public@gmail.com>
#
# vmr is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# vmr is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Foobar.  If not, see <https://www.gnu.org/licenses/>.

# @title Create Vagrantfile VirtualBox configuration
# @name virtualboxVagrantFile
# @description Creates a string usable in a Vagrantfile for virtualbox provider.
# It use params to set options.
# @param params virtualbox options
# @return a character (string)
virtualBoxVagrantFile <- function(params) {
  if (is.null(params)) stop("VirtualBox options not set. See virtualboxOptions()\n")
  paste0(
    '\tconfig.vm.provider "virtualbox" do |vb|\n',
    if (!is.null(params$gui) && isTRUE(params$gui)) {
      paste0("\t\tvb.gui = true\n")
    } else {
      paste0("\t\tvb.gui = false\n")
    },
    if (!is.null(params$name) && params$name != "") paste0('\t\tvb.name = "', params$name, '"\n'),
    if (!is.null(params$nic_type) && params$nic_type != "") paste0('\t\tvb.default_nic_type = "', params$nic_type, '"\n'),
    if (!is.null(params$linked_clone) && params$linked_clone == TRUE) {
      paste0("\t\tvb.linked_clone = true\n")
    } else {
      "\t\tvb.linked_clone = false\n"
    },
    if (!is.null(params$check_guest_additions) && params$check_guest_addition == TRUE) {
      paste0("\t\tvb.check_guest_additions = true\n")
    } else {
      "\t\tvb.check_guest_additions = false\n"
    },


    if (!is.null(params$modifyvm) && length(params$modifyvm) > 0) {
      modif <- ""
      for (name in names(params$modifyvm)) {
        modif <- paste0(modif, '\t\tvb.customize ["modifyvm", :id, "--', name, '", "', params$modifyvm[[name]], '"]\n')
      }
      paste0(modif)
    },
    "\tend\n"
  )
}

# @title Print VirtualBox provider options
# @name virtualboxPrintOptions
# @description Print options from arguments
# @param opts virtualbox provider options as list
# @return opts
virtualboxPrintOptions <- function(opts) {
  if (is.null(opts)) {
    cat("\t# No VirtualBox options\n")
  } else {
    cat("\t# VirtualBox options:\n")
    if (!is.null(opts$name) && !identical(opts$name, character(0))) cat("\t Name: ", opts$name, "\n")
    if (!is.null(opts$gui) && opts$gui == TRUE) {
      cat("\t headless: FALSE\n")
    } else {
      cat("\t headless: TRUE\n")
    }
    if (!is.null(opts$nic_type) && !identical(opts$nic_type, character(0))) cat("\t default NIC type: ", opts$nic_type, "\n")
    if (!is.null(opts$linked_clone) && opts$linked_clone == TRUE) {
      cat("\t linked type: TRUE (clone)\n")
    } else {
      cat("\t linked type: FALSE \n")
    }
    if (!is.null(opts$check_guest_additions) && opts$check_guest_additions == TRUE) {
      cat("\t check guest additions: TRUE\n")
    } else {
      cat("\t check guest additions: ", opts$check_guest_additions, "\n")
    }

    if (!is.null(opts$modifyvm) && length(opts$modifyvm) > 0) {
      cat("\t Modify VM options:\n")
      temp <- lapply(names(opts$modifyvm),
        FUN = function(n) {
          cat("\t\t", n, ": ", opts$modifyvm[[n]], "\n")
        }
      )
    }
  }

  return(opts)
}

#' @title List 'VirtualBox' options available
#' @name virtualboxOptions
#' @description List available options for 'VirtualBox' provider
#' @details Get the 'VirtualBox' default options.
#'   It return a list as follow:
#' ```r
#' list(
#' gui = TRUE,
#' name = NULL,
#' nic_type = NULL,
#' linked_clone = FALSE,
#' check_guest_additions = TRUE,
#' modifyvm = list(cpus = "2", memory = "4096")
#' )
#' ```
#'
#' * __gui__: if TRUE show the GUI, otherwise headless mode is actived
#' * __name__: the 'VirtualBox' instance name
#' * __nic_type__: the NIC type for the network interface to use, by default use the default one.
#'   see [VirtualBox Networking](https://www.virtualbox.org/manual/ch06.html)
#' * __linked_clone__: if TRUE, linked clones are based on a master VM, which is
#'   generated by importing the base box only once the first time it is required.
#'   For the linked clones only differencing disk images are created where
#'   the parent disk image belongs to the master VM.
#'   (Be careful, master VM can't be remove until linked_clone still exists)
#' * __check_guest_additions__: If TRUE (default) check if guest have guest additions installed.
#' * __modifyvm__: list of 'VirtualBox' properties for the guest VM (such as number of cpus, memory size,...).
#'   [see 'VirtualBox' modifyvm](https://www.virtualbox.org/manual/ch08.html#vboxmanage-modifyvm)
#' @param details if TRUE print options (default), otherwise only return default options
#' @return A default list of options
#' ```r
#' list(
#' gui = TRUE,
#' name = NULL,
#' nic_type = NULL,
#' linked_clone = FALSE,
#' check_guest_additions = TRUE,
#' modifyvm = list(cpus = "2", memory = "4096")
#' )
#' ```
#' @examples
#' \dontrun{
#' vb.opts <- virtualboxOptions(details = FALSE)
#' vb.opts$modifyvm$cpus <- "4"
#' vb.opts$modifyvm$memory <- "8192"
#' vb.opts
#' }
#' @export
#' @md
virtualboxOptions <- function(details = TRUE) {
  if (details) {
    cat("VirtualBox provider available options list():\n")
    cat("gui : TRUE to display GUI, FALSE for headless mode\n")
    cat("name : the name of the virtualbox\n")
    cat("nic_type: NIC type for network interfaces (default: use default NIC)\n")
    cat(
      "linked_clone: if TRUE use Master virtual machine and clone disk\n",
      "\t be careful, it speed box creation and reduce overhead but clones are connected to master\n"
    )
    cat("check_guest_additions: if TRUE check if Guest Additions is installed (default FALSE)\n")
    cat(
      "modifyvm: list of virtualbox options to set.\n",
      "https://www.virtualbox.org/manual/ch08.html#vboxmanage-modifyvm\n",
      "ex: list(cpus='4', memory='4096')\n"
    )
  }

  return(list(
    gui = TRUE,
    name = "",
    nic_type = "",
    linked_clone = FALSE,
    check_guest_additions = FALSE,
    modifyvm = list(cpus = "2", memory = "4096")
  ))
}

# @title Load virtualbox options from a VagrantFile
# @name virtualboxReadOptions
# @description Read and load virtualbox form a VagrantFile
# @param text_vector a character vector (vagrantFile)
# @return a list 'vmr' compatible
virtualboxReadOptions <- function(text_vector) {
  res <- list()

  printVerbose(2, "Reading virtualbox options")

  extract_string <- function(text_vector, pattern) {
    text <- text_vector[grep(pattern, text_vector)]
    pos_value <- regexpr('\"[^\"]+\"', text)
    substr(text, pos_value + 1, pos_value + attr(pos_value, "match.length") - 2)
  }

  extract_bool <- function(text_vector, pattern) {
    text <- text_vector[grep(pattern, text_vector)]
    pos_value <- regexpr("=[ ]+.*", text)
    substr(text, pos_value + 2, pos_value + attr(pos_value, "match.length") - 1)
  }

  extract_modifyvm <- function(text_vector, pattern) {
    name_value <- c()
    text <- strsplit(text_vector[grep(pattern, text_vector)], split = ",")
    tt <- lapply(text, function(l) {
      pos_value <- regexpr("[A-Za-z]+", l[3])
      name <- substr(l[3], pos_value, pos_value + attr(pos_value, "match.length") - 1)
      value <- substr(l[4], 3, 3 + nchar(l[4]) - 5)
      name_value <<- c(name_value, name)
      value
    })
    names(tt) <- name_value
    return(tt)
  }

  res$gui <- as.logical(extract_bool(text_vector, "vb.gui"))
  res$name <- as.character(extract_string(text_vector, "vb.name"))
  if (identical(res$name, character(0))) res$name <- ""
  res$nic_type <- as.character(extract_string(text_vector, "vb.default_nic_type"))
  if (identical(res$nic_type, character(0))) res$nic_type <- ""
  res$linked_clone <- as.logical(extract_bool(text_vector, "vb.linked_clone"))
  res$check_guest_additions <- as.logical(extract_bool(text_vector, "vb.check_guest_additions"))
  res$modifyvm <- extract_modifyvm(text_vector, "modifyvm")

  return(res)
}

#' @title Configure the guest VM to be use as a Gitlab-Runner
#' @name virtualboxGitlabRunner
#' @description Configure the guest VM to be use as a GitLab Runner
#'  and return the command to run in shell to register it.
#' @param vmr a __vmr__ object
#' @param gitlab_url a GitLab URL with protocol (http or https)
#' @param gt_token a GitLab registration token
#' @param snapshot_name name of a snapshot to use if any
#' @param vm_name the 'VitualBox' VM name if not specified in 'vmr' object provider_options.
#' @return Character command to run in shell to register it
#' @examples
#' \dontrun{
#' cmd <- virtualboxGitLabRunner(vmr, "gitlab.com", "mytoken")
#' system(cmd)
#' }
#' @export
#' @md
virtualboxGitlabRunner <- function(vmr, gitlab_url, gt_token, snapshot_name = "", vm_name = "") {
  gitlab_url_tmp <- gsub("?(f|ht)tp(s?)://", "", gitlab_url)
  gitlab_url_tmp <- gsub("/$", "", gitlab_url_tmp)
  if(gitlab_url_tmp == gitlab_url) {
    stop(paste0("GitLab URL seems incorrect ", gitlab_url))
  }
  
  printVerbose(1, "Configuring guest machine...\n")
  vagrantSSHCommand("mkdir -p ~/.ssh")
  vagrantSSHCommand("touch ~/.ssh/known_hosts")
  vagrantSSHCommand(paste0("ssh-keyscan -t ecdsa -H ", gitlab_url_tmp, " >> ~/.ssh/known_hosts"))

  printVerbose(2, "Run this command in a shell to enable the VM as a GitLab Runner:")
  cmd <- paste0(
    "gitlab-runner register ",
    "--non-interactive ",
    "--name ", paste0(vmr$org, "-", vmr$box), " ",
    "--url ", gitlab_url, " ",
    "--registration-token ", gt_token, " ",
    "--executor 'virtualbox' ",
    "--tag-list vmr,R4 ",
    "--ssh-user ", vmr$ssh_user, " ",
    "--ssh-password ", vmr$ssh_pwd, " ",
    "--ssh-disable-strict-host-key-checking true ",
    if (vm_name != "") {
      paste0("--virtualbox-base-name '", vm_name, "' ")
    } else {
      if (!is.null(vmr$provider_options$name) && vmr$provider_options$name != "") {
        paste0("--virtualbox-base-name '", vmr$provider_options$name, "' ")
      } else {
        paste0("--virtualbox-base-name '<VirtualBox_Name>' ")
      }
    },
    if (snapshot_name != "") {
      paste0("--virtualbox-base-snapshot='", snapshot_name, "' ")
    },
    "--virtualbox-disable-snapshots"
  )

  printVerbose(2, cmd)

  return(cmd)
}