# Implementation of Rook input stream
InputStream <- R6Class(
  'InputStream',
  public = list(
    initialize = function(conn, length) {
      private$conn <- conn
      private$length <- length
      seek(private$conn, 0)
    },
    read_lines = function(n = -1L) {
      readLines(private$conn, n, warn = FALSE)
    },
    read = function(l = -1L) {
      # l < 0 means read all remaining bytes
      if (l < 0) {
        l <- private$length - seek(private$conn)
      }

      if (l == 0) {
        return(raw())
      } else {
        return(readBin(private$conn, raw(), l))
      }
    },
    rewind = function() {
      seek(private$conn, 0)
    }
  ),
  private = list(
    conn = NULL,
    length = NULL
  ),
  cloneable = FALSE
)

NullInputStream <- R6Class(
  'NullInputStream',
  public = list(
    read_lines = function(n = -1L) {
      character()
    },
    read = function(l = -1L) {
      raw()
    },
    rewind = function() invisible(),
    close = function() invisible()
  ),
  cloneable = FALSE
)
nullInputStream <- NullInputStream$new()

#Implementation of Rook error stream
ErrorStream <- R6Class(
  'ErrorStream',
  public = list(
    cat = function(..., sep = " ", fill = FALSE, labels = NULL) {
      base::cat(..., sep = sep, fill = fill, labels = labels, file = stderr())
    },
    flush = function() {
      base::flush(stderr())
    }
  ),
  cloneable = FALSE
)
stdErrStream <- ErrorStream$new()

rookCall <- function(func, req, data = NULL, dataLength = -1) {
  # Break the processing into two parts: first, the computation with func();
  # second, the preparation of the response object.
  compute <- function() {
    inputStream <- if (is.null(data)) {
      nullInputStream
    } else {
      InputStream$new(data, dataLength)
    }

    req$rook.input <- inputStream

    req$rook.errors <- stdErrStream

    req$httpuv.version <- httpuv_version()

    # These appear to be required for Rook multipart parsing to work
    if (!is.null(req$HTTP_CONTENT_TYPE)) {
      req$CONTENT_TYPE <- req$HTTP_CONTENT_TYPE
    }
    if (!is.null(req$HTTP_CONTENT_LENGTH)) {
      req$CONTENT_LENGTH <- req$HTTP_CONTENT_LENGTH
    }

    # func() may return a regular value or a promise.
    func(req)
  }

  prepare_response <- function(resp) {
    if (is.null(resp) || length(resp) == 0) {
      return(NULL)
    }

    # If headers is an empty unnamed list, convert to named list so that
    # the C++ code won't error.
    if (
      is.null(resp$headers) ||
        (length(resp$headers) == 0 && is.null(names(resp$headers)))
    ) {
      resp$headers <- named_list()
    }

    # Coerce all headers to character
    resp$headers <- lapply(resp$headers, paste)

    if ('file' %in% names(resp$body)) {
      filename <- resp$body[['file']]
      owned <- FALSE
      if ('owned' %in% names(resp$body)) {
        owned <- as.logical(resp$body$owned)
      }

      resp$body <- NULL
      resp$bodyFile <- filename
      resp$bodyFileOwned <- owned
    }
    resp
  }

  on_error <- function(e) {
    list(
      status = 500L,
      headers = list(
        'Content-Type' = 'text/plain; charset=UTF-8'
      ),
      body = charToRaw(enc2utf8(
        paste("ERROR:", conditionMessage(e), collapse = "\n")
      ))
    )
  }

  # First, run the compute function. If it errored, return error response.
  # Then check if it returned a promise. If so, promisify the next step.
  # If not, run the next step immediately.
  compute_error <- NULL
  response <- tryCatch(
    compute(),
    error = function(e) compute_error <<- e
  )
  if (!is.null(compute_error)) {
    return(on_error(compute_error))
  }

  if (is.promise(response)) {
    response %...>% prepare_response %...!% on_error
  } else {
    tryCatch(prepare_response(response), error = on_error)
  }
}

AppWrapper <- R6Class(
  'AppWrapper',
  private = list(
    app = NULL, # List defining app
    wsconns = NULL, # An environment containing websocket connections
    supportsOnHeaders = NULL # Logical
  ),
  public = list(
    initialize = function(app) {
      if (is.function(app)) {
        private$app <- list(call = app)
      } else {
        private$app <- app
      }

      # private$app$onHeaders can error (e.g. if private$app is a reference class)
      private$supportsOnHeaders <- isTRUE(try(
        !is.null(private$app$onHeaders),
        silent = TRUE
      ))

      # staticPaths are saved in a field on this object, because they are read
      # from the app object only during initialization. This is the only time
      # it makes sense to read them from the app object, since they're
      # subsequently used on the background thread, and for performance
      # reasons it can't call back into R. Note that if the app object is a
      # reference object and app$staticPaths is changed later, it will have no
      # effect on the behavior of the application.
      #
      # If private$app is a reference class, accessing private$app$staticPaths
      # can error if not present. Saving here in a separate var because R CMD
      # check complains if you compare class(x) with a string.
      try_obj_class <- class(try(private$app$staticPaths, silent = TRUE))
      if (try_obj_class == "try-error" || is.null(private$app$staticPaths)) {
        self$staticPaths <- list()
      } else {
        self$staticPaths <- normalizeStaticPaths(private$app$staticPaths)
      }

      try_obj_class <- class(try(private$app$staticPathOptions, silent = TRUE))
      if (
        try_obj_class == "try-error" || is.null(private$app$staticPathOptions)
      ) {
        # Use defaults
        self$staticPathOptions <- staticPathOptions()
      } else if (inherits(private$app$staticPathOptions, "staticPathOptions")) {
        self$staticPathOptions <- normalizeStaticPathOptions(
          private$app$staticPathOptions
        )
      } else {
        stop("staticPathOptions must be an object of class staticPathOptions.")
      }

      private$wsconns <- new.env(parent = emptyenv())
    },
    onHeaders = function(req) {
      if (!private$supportsOnHeaders) {
        return(NULL)
      }

      rookCall(private$app$onHeaders, req)
    },
    onBodyData = function(req, bytes) {
      if (is.null(req$.bodyData)) {
        req$.bodyData <- file(open = 'w+b', encoding = 'UTF-8')
      }
      writeBin(bytes, req$.bodyData)
    },
    call = function(req, cpp_callback) {
      # The cpp_callback is an external pointer to a C++ function that writes
      # the response.

      resp <- if (is.null(private$app$call)) {
        list(
          status = 404L,
          headers = list(
            "Content-Type" = "text/plain"
          ),
          body = "404 Not Found\n"
        )
      } else {
        rookCall(private$app$call, req, req$.bodyData, seek(req$.bodyData))
      }
      # Note: rookCall() should never throw error because all the work is
      # wrapped in tryCatch().

      clean_up <- function() {
        if (!is.null(req$.bodyData)) {
          close(req$.bodyData)
        }
        req$.bodyData <- NULL
      }

      if (is.promise(resp)) {
        # Slower path if resp is a promise
        resp <- resp %...>% invokeCppCallback(., cpp_callback)
        finally(resp, clean_up)
      } else {
        # Fast path if resp is a regular value
        on.exit(clean_up())
        invokeCppCallback(resp, cpp_callback)
      }

      invisible()
    },
    onWSOpen = function(handle, req) {
      ws <- WebSocket$new(handle, req)
      private$wsconns[[wsconn_address(handle)]] <- ws
      result <- try(private$app$onWSOpen(ws))

      # If an unexpected error happened, just close up
      if (inherits(result, 'try-error')) {
        ws$close(1011, "Error in onWSOpen")
      }
    },
    onWSMessage = function(handle, binary, message) {
      for (handler in private$wsconns[[wsconn_address(
        handle
      )]]$messageCallbacks) {
        result <- try(handler(binary, message))
        if (inherits(result, 'try-error')) {
          private$wsconns[[wsconn_address(handle)]]$close(
            1011,
            "Error executing onWSMessage"
          )
          return()
        }
      }
    },
    onWSClose = function(handle) {
      ws <- private$wsconns[[wsconn_address(handle)]]
      ws$handle <- NULL
      rm(list = wsconn_address(handle), envir = private$wsconns)

      for (handler in ws$closeCallbacks) {
        handler()
      }
    },

    staticPaths = NULL, # List of static paths
    staticPathOptions = NULL # StaticPathOptions object
  )
)

#' @title WebSocket class
#' @description
#' A `WebSocket` object represents a single WebSocket connection. The
#' object can be used to send messages and close the connection, and to receive
#' notifications when messages are received or the connection is closed.
#'
#' @details
#' Note that this WebSocket class is different from the one provided by the
#' package named websocket. This class is meant to be used on the server side,
#' whereas the one in the websocket package is to be used as a client. The
#' WebSocket class in httpuv has an older API than the one in the websocket
#' package.
#'
#' WebSocket objects should never be created directly. They are obtained by
#' passing an `onWSOpen` function to [startServer()].
#'
#' @export
#' @examples
#'
#' \dontrun{
#' # A WebSocket echo server that listens on port 8080
#' startServer("0.0.0.0", 8080,
#'   list(
#'     onHeaders = function(req) {
#'       # Print connection headers
#'       cat(capture.output(str(as.list(req))), sep = "\n")
#'     },
#'     onWSOpen = function(ws) {
#'       cat("Connection opened.\n")
#'
#'       ws$onMessage(function(binary, message) {
#'         cat("Server received message:", message, "\n")
#'         ws$send(message)
#'       })
#'       ws$onClose(function() {
#'         cat("Connection closed.\n")
#'       })
#'
#'     }
#'   )
#' )
#' }
#' @param handle An C++ WebSocket handle.
WebSocket <- R6Class(
  'WebSocket',
  public = list(
    #' @description
    #' Initializes a new WebSocket object.
    #'
    #' @param req The Rook request environment that opened the connection.
    initialize = function(handle, req) {
      self$handle <- handle
      self$request <- req
    },
    #' @description
    #' Registers a callback function that will be invoked whenever a message is
    #' received on this connection.
    #'
    #' @param func The callback function to be registered. The callback function will be invoked with
    #' two arguments. The first argument is `TRUE` if the message is binary
    #' and `FALSE` if it is text. The second argument is either a raw
    #' vector (if the message is binary) or a character vector.
    onMessage = function(func) {
      self$messageCallbacks <- c(self$messageCallbacks, func)
    },
    #' @description
    #' Registers a callback function that will be invoked when the connection is
    #' closed.
    #' @param func The callback function to be registered.
    onClose = function(func) {
      self$closeCallbacks <- c(self$closeCallbacks, func)
    },
    #' @description
    #' Begins sending the given message over the websocket.
    #'
    #' @param message Either a raw vector, or a single-element character
    #' vector that is encoded in UTF-8.
    send = function(message) {
      if (is.null(self$handle)) {
        return()
      }

      if (is.raw(message)) {
        sendWSMessage(self$handle, TRUE, message)
      } else {
        # TODO: Ensure that message is UTF-8 encoded
        sendWSMessage(self$handle, FALSE, as.character(message))
      }
    },
    #' @description
    #' Closes the websocket connection
    #' @param code An integer that indicates the [WebSocket close
    #'   code](https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/close#code).
    #' @param reason A concise human-readable prose [explanation for the
    #'   closure](https://developer.mozilla.org/en-US/docs/Web/API/WebSocket/close#reason).
    close = function(code = 1000L, reason = "") {
      if (is.null(self$handle)) {
        return()
      }

      # Make sure the code will fit in a short int (2 bytes); if not just use
      # "Going Away" error code.
      code <- as.integer(code)
      if (code < 0 || code > 2^16 - 1) {
        warning("Invalid websocket error code: ", code)
        code <- 1001L
      }
      reason <- iconv(reason, to = "UTF-8")

      closeWS(self$handle, code, reason)
      self$handle <- NULL
    },

    #' @field handle The server handle
    handle = NULL,

    #' @field messageCallbacks A list of callback functions that will be invoked
    #'   when a message is received on this connection.
    messageCallbacks = list(),

    #' @field closeCallbacks A list of callback functions that will be invoked
    #'   when the connection is closed.
    closeCallbacks = list(),

    #' @field request The Rook request environment that opened the connection.
    #'   This can be used to inspect HTTP headers, for example.
    request = NULL
  )
)

#' Create an HTTP/WebSocket server
#'
#' Creates an HTTP/WebSocket server on the specified host and port.
#'
#' @param host A string that is a valid IPv4 address that is owned by this
#'   server, or `"0.0.0.0"` to listen on all IP addresses.
#' @param port A number or integer that indicates the server port that should be
#'   listened on. Note that on most Unix-like systems including Linux and macOS,
#'   port numbers smaller than 1024 require root privileges.
#' @param app A collection of functions that define your application. See
#'   Details.
#' @param quiet If `TRUE`, suppress error messages from starting app.
#' @return A handle for this server that can be passed to
#'   [stopServer()] to shut the server down.
#'
#' @details `startServer` binds the specified port and listens for
#'   connections on an thread running in the background. This background thread
#'   handles the I/O, and when it receives a HTTP request, it will schedule a
#'   call to the user-defined R functions in `app` to handle the request.
#'   This scheduling is done with [later::later()]. When the R call
#'   stack is empty -- in other words, when an interactive R session is sitting
#'   idle at the command prompt -- R will automatically run the scheduled calls.
#'   However, if the call stack is not empty -- if R is evaluating other R code
#'   -- then the callbacks will not execute until either the call stack is
#'   empty, or the [later::run_now()] function is called. This
#'   function tells R to execute any callbacks that have been scheduled by
#'   [later::later()]. The [service()] function is
#'   essentially a wrapper for [later::run_now()].
#'
#'   In older versions of httpuv (1.3.5 and below), it did not use a background
#'   thread for I/O, and when this function was called, it did not accept
#'   connections immediately. It was necessary to call [service()]
#'   repeatedly in order to actually accept and handle connections.
#'
#'   If the port cannot be bound (most likely due to permissions or because it
#'   is already bound), an error is raised.
#'
#'   The application can also specify paths on the filesystem which will be
#'   served from the background thread, without invoking `$call()` or
#'   `$onHeaders()`. Files served this way will be only use a C++ code,
#'   which is faster than going through R, and will not be blocked when R code
#'   is executing. This can greatly improve performance when serving static
#'   assets.
#'
#'   The `app` parameter is where your application logic will be provided
#'   to the server. This can be a list, environment, or reference class that
#'   contains the following methods and fields:
#'
#'   \describe{
#'     \item{`call(req)`}{Process the given HTTP request, and return an
#'     HTTP response (see Response Values). This method should be implemented in
#'     accordance with the
#'     [Rook](https://github.com/jeffreyhorner/Rook/blob/a5e45f751/README.md)
#'     specification. Note that httpuv augments `req` with an additional
#'     item, `req$HEADERS`, which is a named character vector of request
#'     headers.}
#'     \item{`onHeaders(req)`}{Optional. Similar to `call`, but occurs
#'     when headers are received. Return `NULL` to continue normal
#'     processing of the request, or a Rook response to send that response,
#'     stop processing the request, and ask the client to close the connection.
#'     (This can be used to implement upload size limits, for example.)}
#'     \item{`onWSOpen(ws)`}{Called back when a WebSocket connection is established.
#'     The given object can be used to be notified when a message is received from
#'     the client, to send messages to the client, etc. See [WebSocket()].}
#'     \item{`staticPaths`}{
#'       A named list of paths that will be served without invoking
#'       `call()` or `onHeaders`. The name of each one is the URL
#'       path, and the value is either a string referring to a local path, or an
#'       object created by the [staticPath()] function.
#'     }
#'     \item{`staticPathOptions`}{
#'       A set of default options to use when serving static paths. If
#'       not set or `NULL`, then it will use the result from calling
#'       [staticPathOptions()] with no arguments.
#'     }
#'   }
#'
#'   The `startPipeServer` variant can be used instead of
#'   `startServer` to listen on a Unix domain socket or named pipe rather
#'   than a TCP socket (this is not common).
#'
#' @section Response Values:
#'
#' The `call` function is expected to return a list containing the
#' following, which are converted to an HTTP response and sent to the client:
#'
#' \describe{
#'   \item{`status`}{A numeric HTTP status code, e.g. `200` or
#'     `404L`.}
#'
#'   \item{`headers`}{A named list of HTTP headers and their values, as
#'     strings. This can also be missing, an empty list, or `NULL`, in which
#'     case no headers (other than the `Date` and `Content-Length`
#'     headers, as required) will be added.}
#'
#'   \item{`body`}{A string (or `raw` vector) to be sent as the body
#'     of the HTTP response. This can also be omitted or set to `NULL` to
#'     avoid sending any body, which is useful for HTTP `1xx`, `204`,
#'     and `304` responses, as well as responses to `HEAD` requests.}
#' }
#'
#' @return A [WebServer()] or [PipeServer()] object.
#'
#' @seealso [stopServer()], [runServer()],
#'   [listServers()], [stopAllServers()].
#' @aliases startPipeServer
#'
#' @examples
#' \dontrun{
#' # A very basic application
#' s <- startServer("0.0.0.0", 5000,
#'   list(
#'     call = function(req) {
#'       list(
#'         status = 200L,
#'         headers = list(
#'           'Content-Type' = 'text/html'
#'         ),
#'         body = "Hello world!"
#'       )
#'     }
#'   )
#' )
#'
#' s$stop()
#'
#'
#' # An application that serves static assets at the URL paths /assets and /lib
#' s <- startServer("0.0.0.0", 5000,
#'   list(
#'     call = function(req) {
#'       list(
#'         status = 200L,
#'         headers = list(
#'           'Content-Type' = 'text/html'
#'         ),
#'         body = "Hello world!"
#'       )
#'     },
#'     staticPaths = list(
#'       "/assets" = "content/assets/",
#'       "/lib" = staticPath(
#'         "content/lib",
#'         indexhtml = FALSE
#'       ),
#'       # This subdirectory of /lib should always be handled by the R code path
#'       "/lib/dynamic" = excludeStaticPath()
#'     ),
#'     staticPathOptions = staticPathOptions(
#'       indexhtml = TRUE
#'     )
#'   )
#' )
#'
#' s$stop()
#' }
#' @export
startServer <- function(host, port, app, quiet = FALSE) {
  WebServer$new(host, port, app, quiet)
}

#' @param name A string that indicates the path for the domain socket (on
#'   Unix-like systems) or the name of the named pipe (on Windows).
#' @param mask If non-`NULL` and non-negative, this numeric value is used
#'   to temporarily modify the process's umask while the domain socket is being
#'   created. To ensure that only root can access the domain socket, use
#'   `strtoi("777", 8)`; or to allow owner and group read/write access, use
#'   `strtoi("117", 8)`. If the value is `NULL` then the process's
#'   umask is left unchanged. (This parameter has no effect on Windows.)
#' @rdname startServer
#' @export
startPipeServer <- function(name, mask, app, quiet = FALSE) {
  PipeServer$new(name, mask, app, quiet)
}

#' Process requests
#'
#' Process HTTP requests and WebSocket messages. If there is nothing on R's call
#' stack -- if R is sitting idle at the command prompt -- it is not necessary to
#' call this function, because requests will be handled automatically. However,
#' if R is executing code, then requests will not be handled until either the
#' call stack is empty, or this function is called (or alternatively,
#' [later::run_now()] is called).
#'
#' In previous versions of httpuv (1.3.5 and below), even if a server created by
#' [startServer()] exists, no requests were serviced unless and until
#' `service` was called.
#'
#' This function simply calls [later::run_now()], so if your
#' application schedules any [later::later()] callbacks, they will be
#' invoked.
#'
#' @param timeoutMs Approximate number of milliseconds to run before returning.
#'   It will return this duration has elapsed. If 0 or Inf, then the function
#'   will continually process requests without returning unless an error occurs.
#'   If NA, performs a non-blocking run without waiting.
#'
#' @examples
#' \dontrun{
#' while (TRUE) {
#'   service()
#' }
#' }
#'
#' @export
service <- function(timeoutMs = ifelse(interactive(), 100, 1000)) {
  # In all cases, call `run_now` with `all = FALSE` so that if there is a lot of
  # incoming traffic (relative to the time it takes to process it) we give the
  # owning event loop opportunities to do housekeeping in between httpuv related
  # callbacks.

  if (is.na(timeoutMs)) {
    # NA means to run non-blocking
    run_now(0, all = FALSE)
  } else if (timeoutMs == 0 || timeoutMs == Inf) {
    .globals$paused <- FALSE
    # In interactive sessions, wait for a max of 0.1 seconds for better
    # responsiveness when the user sends an interrupt (like Esc in RStudio.)
    check_time <- if (interactive()) 0.1 else Inf
    while (!.globals$paused) {
      run_now(check_time, all = FALSE)
    }
  } else {
    # No need to check for .globals$paused because if run_now() executes
    # anything, it will return immediately.
    run_now(timeoutMs / 1000, all = FALSE)
  }

  # Some code expects service() to return TRUE (#123)
  TRUE
}

#' Run a server
#'
#' This is a convenience function that provides a simple way to call
#' [startServer()], [service()], and
#' [stopServer()] in the correct sequence. It does not return unless
#' interrupted or an error occurs.
#'
#' If you have multiple hosts and/or ports to listen on, call the individual
#' functions instead of `runServer`.
#'
#' @param host A string that is a valid IPv4 or IPv6 address that is owned by
#'   this server, which the application will listen on. `"0.0.0.0"`
#'   represents all IPv4 addresses and `"::/0"` represents all IPv6
#'   addresses.
#' @param port A number or integer that indicates the server port that should be
#'   listened on. Note that on most Unix-like systems including Linux and macOS,
#'   port numbers smaller than 1024 require root privileges.
#' @param app A collection of functions that define your application. See
#'   [startServer()].
#' @param interruptIntervalMs Deprecated (last used in httpuv 1.3.5).
#'
#' @seealso [startServer()], [service()],
#'   [stopServer()]
#'
#' @examples
#' \dontrun{
#' # A very basic application
#' runServer("0.0.0.0", 5000,
#'   list(
#'     call = function(req) {
#'       list(
#'         status = 200L,
#'         headers = list(
#'           'Content-Type' = 'text/html'
#'         ),
#'         body = "Hello world!"
#'       )
#'     }
#'   )
#' )
#' }
#' @export
runServer <- function(host, port, app, interruptIntervalMs = NULL) {
  server <- startServer(host, port, app)
  on.exit(stopServer(server))

  # TODO: in the future, add deprecation message to interruptIntervalMs.
  service(0)
}

#' Interrupt httpuv runloop
#'
#' Interrupts the currently running httpuv runloop, meaning
#' [runServer()] or [service()] will return control back to
#' the caller and no further tasks will be processed until those methods are
#' called again. Note that this may cause in-process uploads or downloads to be
#' interrupted in mid-request.
#'
#' @export
interrupt <- function() {
  .globals$paused <- TRUE
}

#' Convert raw vector to Base64-encoded string
#'
#' Converts a raw vector to its Base64 encoding as a single-element character
#' vector.
#'
#' @param x A raw vector.
#'
#' @examples
#' set.seed(100)
#' result <- rawToBase64(as.raw(runif(19, min=0, max=256)))
#' stopifnot(identical(result, "TkGNDnd7z16LK5/hR2bDqzRbXA=="))
#'
#' @export
rawToBase64 <- function(x) {
  base64encode(x)
}

.globals <- new.env()


#' Create an HTTP/WebSocket daemonized server (deprecated)
#'
#' This function will be removed in a future release of httpuv. It is simply a
#' wrapper for [startServer()]. In previous versions of httpuv (1.3.5
#' and below), `startServer` ran applications in the foreground and
#' `startDaemonizedServer` ran applications in the background, but now both
#' of them run applications in the background.
#'
#' @inheritParams startServer
#' @export
startDaemonizedServer <- startServer
