R/hotwire-demo.R

In tjpalanca/hotwire.R: Hotwire for R

#' @title Hotwire Demonstration App
#'
#' @description
#' This demonstration app is an exposition of the various features of Hotwire
#' Turbo and Stimulus.
#'
#' @param ... (plugins) additional plugins
#' @return [`webtools::App`] object that can be run using `$lifecycle_start()`.
#'
#' @family Hotwire
#' @export
hotwire_demo <- function(...) {

  # Initialize application
  app <- App$new(
    AsyncPlugin$new(),
    HTMLPlugin$new(),
    Turbo$new(
      turbo_socket = TRUE,
      app_version  = pkg_vers()
    ),
    Stimulus$new(
      app_version = pkg_vers(),
      controllers = pkg_inst("demo_app")
    ),
    Hotwire$new(),
    ...
  )

  # Favicon
  app$static("/favicon.ico", pkg_inst("img/hotwire-reduced.png"))

  # Logo
  app$static("/logo.png", pkg_inst("img/logo.png"))

  # Home Page
  app$hotwire$router(
    "/",
    function(request, response, keys, ...) {
      response$body <- html_template(
        pkg_inst("demo_app/homepage.html"),
        assets = hotwire_demo_assets(),
        turbo_drive = html_template(
          pkg_inst("demo_app/turbo_drive.html")
        ),
        turbo_frames = html_template(
          pkg_inst("demo_app/turbo_frames.html"),
          lazy_loaded_frame = turbo_frame(
            id = "lazy_loading",
            src = "lazy_loading"
          ),
          swapped_frame = turbo_frame(
            id = "swapped_frame",
            p("This is not yet swapped. When you click the link below,
              it will be swapped with the same frame in ",
              code("/swapped_frame"), "."),
            a(href = "/swapped_frame", "Swap this Frame")
          ),
          trigger_frame = turbo_frame(
            id = "trigger_frame",
            target = "target_frame",
            a(href = "/swapped_frame", "Swap the other frame")
          ),
          target_frame = turbo_frame(
            id = "target_frame",
            "You have not yet swapped this out."
          ),
          page_trigger_frame = turbo_frame(
            id = "page_trigger_frame",
            target = "_top",
            a(href = "/swapped_frame", "This will target the whole page")
          ),
          isolated_link_frame = turbo_frame(
            id = "isolated_link_frame",
            a(href = "/swapped_frame", "This will swap itself"), br(),
            turbo_link(
              href  = "/swapped_frame",
              frame = "_top",
              "This will swap the whole page"
            )
          )
        ),
        turbo_streams = html_template(
          pkg_inst("demo_app/turbo_streams.html")
        ),
        stimulus = html_template(
          pkg_inst("demo_app/stimulus.html"),
          greet = ss_control("hello", div(
            ss_target("name", input(type = "text")),
            ss_action("click", "greet", button("Greet!")),
            ss_target("output", span(style = "border: 1px solid red;"))
          )),
          copy = ss_control("copy", div(
            ss_target("text", input(type = "text")),
            ss_action("click", "copy", button("Copy to Clipboard"))
          )),
          slideshow = ss_control("slideshow", div(
            ss_action(NULL, "previous", button("<-")),
            ss_action(NULL, "next", button("->")),
            ss_target("slide", div("\xF0\x9F\x90\xB5")),
            ss_target("slide", div("\xF0\x9F\x99\x88")),
            ss_target("slide", div("\xF0\x9F\x99\x89")),
            ss_target("slide", div("\xF0\x9F\x99\x8A"))
          )),
          slideshow2 = ss_control(
            "slideshow_2", div(
              ss_action(NULL, "previous", button("<-")),
              ss_action(NULL, "next", button("->")),
              ss_target("slide", div("\xF0\x9F\x90\xB5")),
              ss_target("slide", div("\xF0\x9F\x99\x88")),
              ss_target("slide", div("\xF0\x9F\x99\x89")),
              ss_target("slide", div("\xF0\x9F\x99\x8A"))
            ),
            values = list(index = 1)
          ),
          async_html = ss_control(
            "async_html", div(
              style = css(border = "1px solid red")
            ),
            values = list(url = "time", interval = 5000L)
          ),
          css_classes = ss_control(
            "css_classes", div(
              ss_action(NULL, "danger", button("Danger")),
              ss_action(NULL, "success", button("Success")),
              ss_target(
                "box",
                div(style = css(height = "100px", width = "100px"))
              )
            ),
            classes = list(danger = "red", success = "green")
          )
        )
      )
    }
  )

  # Turbo Drive
  app$turbo$router(
    "/turbo_drive",
    function(request, response, keys, ...) {
      response$body <- html_tags(
        hotwire_demo_assets(),
        div(
          style = css(max_width    = "768px",
                      margin_left  = "auto",
                      margin_right = "auto"),
          h1("Hotwire for R"),
          p("Hopefully, you navigated to this page with Turbo Drive."),
          p("Notice how there was no rash page refresh on load."),
          p("Click ", a(href = "../", "here"), "to go back.")
        )
      )
    }
  )

  # Turbo Frame Swap
  app$turbo$router(
    "/swapped_frame",
    function(request, response, keys, ...) {
      response$body <- html_tags(
        div(
          HTML("
          <p>If you are seeing this then you likely went here from the frame
          that targets the whole page. Go <a href='../'>here<a/> to return.
          "),
          turbo_frame(
            id = "swapped_frame",
            "You have swapped this with the response!"
          ),
          turbo_frame(
            id = "target_frame",
            "You have swapped this with the response from a different endpoint!"
          ),
          turbo_frame(
            id = "isolated_link_frame",
            "Swapped itself!"
          )
        )
      )
    }
  )

  # Slow Turbo Drive
  app$turbo$router(
    "/slow_drive",
    function(request, response, keys, ...) {
      Sys.sleep(1L)
      response$body <- html_tags(
        hotwire_demo_assets(),
        div(
          style = css(max_width    = "768px",
                      margin_left  = "auto",
                      margin_right = "auto"),
          h1("Hotwire for R"),
          p("This is deliberately slowed down by 1 second."),
          p("Click ", a(href = "../", "here"), "to go back.")
        )
      )
    }
  )

  # Lazy Loaded Frame
  app$turbo$router(
    "/lazy_loading",
    function(request, response, keys, ...) {
      response$body <- html_tags(
        turbo_frame(
          id = "lazy_loading",
          p("I am from a different path, specifically ",
            turbo_disable(a(href = "lazy_loading", "here")), ".")
        )
      )
    }
  )

  # Turbo Stream Response
  app$turbo$router_stream(
    "/stream/:action",
    function(request, response, keys, ...) {
      request$parse(parsers)
      response$body <- turbo_stream(
        keys$action,
        "stream_target",
        div(
          id = if (keys$action %in% c("replace", "update")) "stream_target",
          style = if (keys$action %in% c("replace", "update"))
            css(border = "1px solid black;"),
          request$body$text
        )
      )
    }
  )

  # Start websocket turbo stream udpate
  app$router(
    "/start",
    methods = "post",
    function(request, response, keys, ...) {
      response$status_with_text(303L)
      app$async$time(
        name = "clock",
        expr = NULL,
        then = function(res, server) {
          # nocov start
          app$turbo$stream(
            "update",
            "websocket_stream_target",
            Sys.time()
          )
          # nocov end
        },
        after = 1L,
        loop = TRUE
      )
    }
  )

  # Start websocket turbo stream udpate
  app$turbo$router_stream(
    "/multiple/:letter",
    function(request, response, keys, ...) {
      response$body <- turbo_stream(
        "remove",
        paste0(".", keys$letter),
        multiple = TRUE
      )
    }
  )

  # Return Current Time
  app$html$router(
    "/time",
    function(request, response, keys, ...) {
      response$body <- html_tags(em(Sys.time()))
    }
  )

  return(app)

}

hotwire_demo_assets <- function() {

  html_tags(head(
    title("Hotwire for R Demo"),
    link(rel = "preconnect", href = "https://fonts.googleapis.com"),
    link(rel = "preconnect", href = "https://fonts.gstatic.com",
         crossorigin = NA),
    link(href = "https://fonts.googleapis.com/css2?family=IBM+Plex+Sans",
         rel = "stylesheet"),
    style(
      "body { font-family: 'IBM Plex Sans', ",
      "sans-serif; background-color: #fafafa; }"
    )
  ))

}