1# Creates an object whose $ and [[ pass through to the parent
2# session, unless the name is matched in ..., in which case
3# that value is returned instead. (See Decorator pattern.)
4createSessionProxy <- function(parentSession, ...) {
5  e <- new.env(parent = emptyenv())
6  e$parent <- parentSession
7  e$overrides <- list(...)
8
9  structure(
10    e,
11    class = "session_proxy"
12  )
13}
14
15#' @export
16`$.session_proxy` <- function(x, name) {
17  if (name %in% names(.subset2(x, "overrides")))
18    .subset2(x, "overrides")[[name]]
19  else
20    .subset2(x, "parent")[[name]]
21}
22
23#' @export
24`[[.session_proxy` <- `$.session_proxy`
25
26
27#' @export
28`$<-.session_proxy` <- function(x, name, value) {
29  # this line allows users to write into session$userData
30  # (e.g. it allows something like `session$userData$x <- TRUE`,
31  # but not `session$userData <- TRUE`) from within a module
32  # without any hacks (see PR #1732)
33  if (identical(x[[name]], value)) return(x)
34
35  # Special case for $options (issue #3112)
36  if (name == "options") {
37    session <- find_ancestor_session(x)
38    session[[name]] <- value
39    return(x)
40  }
41
42  stop("Attempted to assign value on session proxy.")
43}
44
45`[[<-.session_proxy` <- `$<-.session_proxy`
46
47# Given a session_proxy, search `parent` recursively to find the real
48# ShinySession object. If given a ShinySession, simply return it.
49find_ancestor_session <- function(x, depth = 20) {
50  if (depth < 0) {
51    stop("ShinySession not found")
52  }
53  if (inherits(x, "ShinySession")) {
54    return(x)
55  }
56  if (inherits(x, "session_proxy")) {
57    return(find_ancestor_session(.subset2(x, "parent"), depth-1))
58  }
59
60  stop("ShinySession not found")
61}
62
63
64#' Shiny modules
65#'
66#' Shiny's module feature lets you break complicated UI and server logic into
67#' smaller, self-contained pieces. Compared to large monolithic Shiny apps,
68#' modules are easier to reuse and easier to reason about. See the article at
69#' <https://shiny.rstudio.com/articles/modules.html> to learn more.
70#'
71#' Starting in Shiny 1.5.0, we recommend using `moduleServer` instead of
72#' [`callModule()`], because the syntax is a little easier
73#' to understand, and modules created with `moduleServer` can be tested with
74#' [`testServer()`].
75#'
76#' @param module A Shiny module server function.
77#' @param id An ID string that corresponds with the ID used to call the module's
78#'   UI function.
79#' @param session Session from which to make a child scope (the default should
80#'   almost always be used).
81#'
82#' @return The return value, if any, from executing the module server function
83#' @seealso <https://shiny.rstudio.com/articles/modules.html>
84#'
85#' @examples
86#' # Define the UI for a module
87#' counterUI <- function(id, label = "Counter") {
88#'   ns <- NS(id)
89#'   tagList(
90#'     actionButton(ns("button"), label = label),
91#'     verbatimTextOutput(ns("out"))
92#'   )
93#' }
94#'
95#' # Define the server logic for a module
96#' counterServer <- function(id) {
97#'   moduleServer(
98#'     id,
99#'     function(input, output, session) {
100#'       count <- reactiveVal(0)
101#'       observeEvent(input$button, {
102#'         count(count() + 1)
103#'       })
104#'       output$out <- renderText({
105#'         count()
106#'       })
107#'       count
108#'     }
109#'   )
110#' }
111#'
112#' # Use the module in an app
113#' ui <- fluidPage(
114#'   counterUI("counter1", "Counter #1"),
115#'   counterUI("counter2", "Counter #2")
116#' )
117#' server <- function(input, output, session) {
118#'   counterServer("counter1")
119#'   counterServer("counter2")
120#' }
121#' if (interactive()) {
122#'   shinyApp(ui, server)
123#' }
124#'
125#'
126#'
127#' # If you want to pass extra parameters to the module's server logic, you can
128#' # add them to your function. In this case `prefix` is text that will be
129#' # printed before the count.
130#' counterServer2 <- function(id, prefix = NULL) {
131#'   moduleServer(
132#'     id,
133#'     function(input, output, session) {
134#'       count <- reactiveVal(0)
135#'       observeEvent(input$button, {
136#'         count(count() + 1)
137#'       })
138#'       output$out <- renderText({
139#'         paste0(prefix, count())
140#'       })
141#'       count
142#'     }
143#'   )
144#' }
145#'
146#' ui <- fluidPage(
147#'   counterUI("counter", "Counter"),
148#' )
149#' server <- function(input, output, session) {
150#'   counterServer2("counter", "The current count is: ")
151#' }
152#' if (interactive()) {
153#'   shinyApp(ui, server)
154#' }
155#'
156#' @export
157moduleServer <- function(id, module, session = getDefaultReactiveDomain()) {
158  if (inherits(session, "MockShinySession")) {
159    body(module) <- rlang::expr({
160      session$setEnv(base::environment())
161      !!body(module)
162    })
163    session$setReturned(callModule(module, id, session = session))
164  } else {
165    callModule(module, id, session = session)
166  }
167}
168
169
170#' Invoke a Shiny module
171#'
172#' Note: As of Shiny 1.5.0, we recommend using [`moduleServer()`] instead of
173#' [`callModule()`], because the syntax is a little easier
174#' to understand, and modules created with `moduleServer` can be tested with
175#' [`testServer()`].
176#'
177#' @param module A Shiny module server function
178#' @param id An ID string that corresponds with the ID used to call the module's
179#'   UI function
180#' @param ... Additional parameters to pass to module server function
181#' @param session Session from which to make a child scope (the default should
182#'   almost always be used)
183#'
184#' @return The return value, if any, from executing the module server function
185#' @export
186callModule <- function(module, id, ..., session = getDefaultReactiveDomain()) {
187  if (!inherits(session, c("ShinySession", "session_proxy", "MockShinySession"))) {
188    stop("session must be a ShinySession or session_proxy object.")
189  }
190  childScope <- session$makeScope(id)
191
192  withReactiveDomain(childScope, {
193    if (!is.function(module)) {
194      stop("module argument must be a function")
195    }
196
197    module(childScope$input, childScope$output, childScope, ...)
198  })
199}
200