Encrypt password with md5 for Shiny-app.

server.R

library(shiny)
library(datasets)
Logged = FALSE;
PASSWORD <- data.frame(Brukernavn = "withr", Passord = "25d55ad283aa400af464c76d713c07ad")
# Define server logic required to summarize and view the selected dataset
shinyServer(function(input, output) {
  source("www/Login.R",  local = TRUE)
  
  observe({
    if (USER$Logged == TRUE) {
      output$obs <- renderUI({
        sliderInput("obs", "Number of observations:", 
                    min = 10000, max = 90000, 
                    value = 50000, step = 10000)
      })
      
      output$distPlot <- renderPlot({
        dist <- NULL
        dist <- rnorm(input$obs)
        hist(dist, breaks = 100, main = paste("Your password:", input$passwd))
      })
    }
  })
})

ui.R

shinyUI(bootstrapPage(
  # Add custom CSS & Javascript;
  tagList(
    tags$head(
      tags$link(rel="stylesheet", type="text/css",href="style.css"),
      tags$script(type="text/javascript", src = "md5.js"),
      tags$script(type="text/javascript", src = "passwdInputBinding.js")
    )
  ),
  
  ## Login module;
  div(class = "login",
      uiOutput("uiLogin"),
      textOutput("pass")
  ), 
  
  div(class = "span4", uiOutput("obs")),
  div(class = "span8", plotOutput("distPlot"))
  
))

www\Login.R

#### Log in module ###
USER <- reactiveValues(Logged = Logged)

passwdInput <- function(inputId, label) {
  tagList(
    tags$label(label),
    tags$input(id = inputId, type="password", value="")
  )
}

output$uiLogin <- renderUI({
  if (USER$Logged == FALSE) {
    wellPanel(
      textInput("userName", "User Name:"),
      passwdInput("passwd", "Pass word:"),
      br(),
      actionButton("Login", "Log in")
    )
  }
})

output$pass <- renderText({  
  if (USER$Logged == FALSE) {
    if (!is.null(input$Login)) {
   if (input$Login > 0) {
      Username <- isolate(input$userName)
      Password <- isolate(input$passwd)
      Id.username <- which(PASSWORD$Brukernavn == Username)
      Id.password <- which(PASSWORD$Passord    == Password)
      if (length(Id.username) > 0 & length(Id.password) > 0) {
        if (Id.username == Id.password) {
          USER$Logged <- TRUE
        } 
      } else  {
        "User name or password failed!"
      }
    } 
    }
  }
})

www\md5.js

// Downloaded from: http://www.myersdaily.org/joseph/javascript/md5.js;

function md5cycle(x, k) {
  var a = x[0], b = x[1], c = x[2], d = x[3];
  
  a = ff(a, b, c, d, k[0], 7, -680876936);
  d = ff(d, a, b, c, k[1], 12, -389564586);
  c = ff(c, d, a, b, k[2], 17,  606105819);
  b = ff(b, c, d, a, k[3], 22, -1044525330);
  a = ff(a, b, c, d, k[4], 7, -176418897);
  d = ff(d, a, b, c, k[5], 12,  1200080426);
  c = ff(c, d, a, b, k[6], 17, -1473231341);
  b = ff(b, c, d, a, k[7], 22, -45705983);
  a = ff(a, b, c, d, k[8], 7,  1770035416);
  d = ff(d, a, b, c, k[9], 12, -1958414417);
  c = ff(c, d, a, b, k[10], 17, -42063);
  b = ff(b, c, d, a, k[11], 22, -1990404162);
  a = ff(a, b, c, d, k[12], 7,  1804603682);
  d = ff(d, a, b, c, k[13], 12, -40341101);
  c = ff(c, d, a, b, k[14], 17, -1502002290);
  b = ff(b, c, d, a, k[15], 22,  1236535329);
  
  a = gg(a, b, c, d, k[1], 5, -165796510);
  d = gg(d, a, b, c, k[6], 9, -1069501632);
  c = gg(c, d, a, b, k[11], 14,  643717713);
  b = gg(b, c, d, a, k[0], 20, -373897302);
  a = gg(a, b, c, d, k[5], 5, -701558691);
  d = gg(d, a, b, c, k[10], 9,  38016083);
  c = gg(c, d, a, b, k[15], 14, -660478335);
  b = gg(b, c, d, a, k[4], 20, -405537848);
  a = gg(a, b, c, d, k[9], 5,  568446438);
  d = gg(d, a, b, c, k[14], 9, -1019803690);
  c = gg(c, d, a, b, k[3], 14, -187363961);
  b = gg(b, c, d, a, k[8], 20,  1163531501);
  a = gg(a, b, c, d, k[13], 5, -1444681467);
  d = gg(d, a, b, c, k[2], 9, -51403784);
  c = gg(c, d, a, b, k[7], 14,  1735328473);
  b = gg(b, c, d, a, k[12], 20, -1926607734);
  
  a = hh(a, b, c, d, k[5], 4, -378558);
  d = hh(d, a, b, c, k[8], 11, -2022574463);
  c = hh(c, d, a, b, k[11], 16,  1839030562);
  b = hh(b, c, d, a, k[14], 23, -35309556);
  a = hh(a, b, c, d, k[1], 4, -1530992060);
  d = hh(d, a, b, c, k[4], 11,  1272893353);
  c = hh(c, d, a, b, k[7], 16, -155497632);
  b = hh(b, c, d, a, k[10], 23, -1094730640);
  a = hh(a, b, c, d, k[13], 4,  681279174);
  d = hh(d, a, b, c, k[0], 11, -358537222);
  c = hh(c, d, a, b, k[3], 16, -722521979);
  b = hh(b, c, d, a, k[6], 23,  76029189);
  a = hh(a, b, c, d, k[9], 4, -640364487);
  d = hh(d, a, b, c, k[12], 11, -421815835);
  c = hh(c, d, a, b, k[15], 16,  530742520);
  b = hh(b, c, d, a, k[2], 23, -995338651);
  
  a = ii(a, b, c, d, k[0], 6, -198630844);
  d = ii(d, a, b, c, k[7], 10,  1126891415);
  c = ii(c, d, a, b, k[14], 15, -1416354905);
  b = ii(b, c, d, a, k[5], 21, -57434055);
  a = ii(a, b, c, d, k[12], 6,  1700485571);
  d = ii(d, a, b, c, k[3], 10, -1894986606);
  c = ii(c, d, a, b, k[10], 15, -1051523);
  b = ii(b, c, d, a, k[1], 21, -2054922799);
  a = ii(a, b, c, d, k[8], 6,  1873313359);
  d = ii(d, a, b, c, k[15], 10, -30611744);
  c = ii(c, d, a, b, k[6], 15, -1560198380);
  b = ii(b, c, d, a, k[13], 21,  1309151649);
  a = ii(a, b, c, d, k[4], 6, -145523070);
  d = ii(d, a, b, c, k[11], 10, -1120210379);
  c = ii(c, d, a, b, k[2], 15,  718787259);
  b = ii(b, c, d, a, k[9], 21, -343485551);
  
  x[0] = add32(a, x[0]);
  x[1] = add32(b, x[1]);
  x[2] = add32(c, x[2]);
  x[3] = add32(d, x[3]);
  
}

function cmn(q, a, b, x, s, t) {
  a = add32(add32(a, q), add32(x, t));
  return add32((a << s) | (a >>> (32 - s)), b);
}

function ff(a, b, c, d, x, s, t) {
  return cmn((b & c) | ((~b) & d), a, b, x, s, t);
}

function gg(a, b, c, d, x, s, t) {
  return cmn((b & d) | (c & (~d)), a, b, x, s, t);
}

function hh(a, b, c, d, x, s, t) {
  return cmn(b ^ c ^ d, a, b, x, s, t);
}

function ii(a, b, c, d, x, s, t) {
  return cmn(c ^ (b | (~d)), a, b, x, s, t);
}

function md51(s) {
  txt = '';
  var n = s.length,
  state = [1732584193, -271733879, -1732584194, 271733878], i;
  for (i=64; i<=s.length; i+=64) {
    md5cycle(state, md5blk(s.substring(i-64, i)));
  }
  s = s.substring(i-64);
  var tail = [0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0];
  for (i=0; i<s.length; i++)
    tail[i>>2] |= s.charCodeAt(i) << ((i%4) << 3);
  tail[i>>2] |= 0x80 << ((i%4) << 3);
  if (i > 55) {
    md5cycle(state, tail);
    for (i=0; i<16; i++) tail[i] = 0;
  }
  tail[14] = n*8;
  md5cycle(state, tail);
  return state;
}

function md5blk(s) { /* I figured global was faster.   */
  var md5blks = [], i; /* Andy King said do it this way. */
  for (i=0; i<64; i+=4) {
    md5blks[i>>2] = s.charCodeAt(i)
    + (s.charCodeAt(i+1) << 8)
    + (s.charCodeAt(i+2) << 16)
    + (s.charCodeAt(i+3) << 24);
  }
  return md5blks;
}

var hex_chr = '0123456789abcdef'.split('');

function rhex(n)
{
  var s='', j=0;
  for(; j<4; j++)
    s += hex_chr[(n >> (j * 8 + 4)) & 0x0F]
  + hex_chr[(n >> (j * 8)) & 0x0F];
  return s;
}

function hex(x) {
  for (var i=0; i<x.length; i++)
    x[i] = rhex(x[i]);
  return x.join('');
}

function md5(s) {
  return hex(md51(s));
}

function add32(a, b) {
  return (a + b) & 0xFFFFFFFF;
}

if (md5('hello') != '5d41402abc4b2a76b9719d911017c592') {
  function add32(x, y) {
    var lsw = (x & 0xFFFF) + (y & 0xFFFF),
    msw = (x >> 16) + (y >> 16) + (lsw >> 16);
    return (msw << 16) | (lsw & 0xFFFF);
  }
}

www\passwdInputBinding.js

jQuery(function($) {
  // Password Input
  var passwordInputBinding = new Shiny.InputBinding();
  $.extend(passwordInputBinding, {
    find: function(scope) {
      return $(scope).find('input[type="password"]');
    },
    getId: function(el) {
      return Shiny.InputBinding.prototype.getId.call(this, el) || el.name;
    },
    getValue: function(el) {
      return md5(el.value);
    },
    setValue: function(el, value) {
      el.value = value;
    },
    subscribe: function(el, callback) {
      $(el).on('keyup.passwordInputBinding input.passwordInputBinding', function(event) {
        callback(true);
      });
      $(el).on('change.passwordInputBinding', function(event) {
        callback(false);
      });
    },
    unsubscribe: function(el) {
      $(el).off('.passwordInputBinding');
    },
    getRatePolicy: function() {
      return {
        policy: 'debounce',
        delay: 250
      };
    }
  });
  Shiny.inputBindings.register(passwordInputBinding, 'shiny.passwordInput');
})

www\style.css

div.login { 
  text-align: left;
  position:absolute;
  top: 40%;
  left: 50%;
  margin-top: -100px;
  margin-left: -150px;
} 

div#pass {
  text-align: left;
  font-weight:bold;
  padding-left:2px;
}

input#Password {
  -webkit-text-security: disc;
}

body {
  margin:1cm;
  font-size: 12px;
}

.shiny-output-error {
  visibility: hidden;
}

This is fantastic. Is it possible to code a logout button? I have tried adding a logoutButton and processing it like below. However, this event is called but then immediately after the user is logged back in. My guess is that the values in the username and password text boxes are still there and being resubmitted, therefore undoing my logout. Any thoughts or help would greatly appreciated.

    observeEvent(input$logoutButton, {
        if(!is.null(input$logoutButton) & input$logoutButton == 1) {
            USER$Logged <- FALSE
            print(input$username)
        }
    })

Note: I added the print statement there and the value of input$username has the value from the first successful login attempt.

Well, I figured out a solution. In order to force Shiny to re-render the username and password boxes, I need to change the id. My modified Login.R is below. I define a new uiLogout to create a logout button. The tl;dr is that I concatenate the current date and time to seconds to the id of the username and password fields. In order to know what the id is on both the ui and server side, I save it to the USER list. T

# See https://gist.github.com/withr/9001831 for more information

USER <- reactiveValues(Logged = Logged, 
                       Unique = format(Sys.time(), '%Y%m%d%H%M%S'),
                       Username = NA)

passwdInput <- function(inputId, label, value) {
    tagList(
        tags$label(label),
        tags$input(id=inputId, type="password", value=value)
    )
}

output$uiLogin <- renderUI({
    if(USER$Logged == FALSE) {
        wellPanel(
            div(textInput(paste0("username", USER$Unique), "Username: ", value='')),
            div(passwdInput(paste0("password", USER$Unique), "Password: ", value='')),
            br(), br(),
            actionButton("Login", "Login")
        )
    }
})

output$uiLogout <- renderUI({
    actionButton('logoutButton', 'Logout')
})

observeEvent(input$logoutButton, {
    if(!is.null(input$logoutButton) & input$logoutButton == 1) {
        USER$Logged <- FALSE
        USER$Username <- NA
        USER$Unique <- format(Sys.time(), '%Y%m%d%H%M%S')
    }
})

output$pass <- renderText({
    if(USER$Logged == FALSE) {
        if(!is.null(input$Login)) {
            if(input$Login > 0) {
                Username <- isolate(input[[paste0('username', USER$Unique)]])
                Password <- isolate(input[[paste0('password', USER$Unique)]])
                Id.username <- which(PASSWORD$Username == Username)
                if(length(Id.username) == 1 & 
                    Password == PASSWORD[Id.username,]$Password) {
                    USER$Logged <- TRUE
                    USER$Username <- Username
                } else  {
                    "Username or password failed!"
                }
            } 
        }
    }
})

Thanks for this great example.
But unable to get the login panel when plot is created in a fluidrow.
Any suggestion on this highly appreciated.

Hey jbryer ,

Can you give a working example of how exactly you are doing this ?

with

passwd {

display: block;
width: 100%;
height: 34px;
}

the username is a round-corner rectangle, but the password is a 90deg corner rectangle. how do we change them to either one? either round-corner rectangle or 90deg rectangle for both username and password text input.
thanks.

jbryer commented on Feb 3, which I try, but there is no logout button, and it does not work.

I'm not able to enter the username or password, the login window pops up but I'm not able to enter the username or password

@Nisalz

Just rewrite the following line in server.R
PASSWORD <- data.frame(Brukernavn = c("withr","pachiras"), Passord = c("25d55ad283aa400af464c76d713c07ad","81b073de9370ea873f548e31b8adc081")

Just in case multiple users have a same password, you have to change the line in Login.R from
if (Id.username == Id.password) { USER$Logged <- TRUE }
to
if (Id.username %in% Id.password) { USER$Logged <- TRUE }

@pachiras
How Can I obtain 25d55ad283aa400af464c76d713c07ad from 12345678 using R?
Thanks

We can use MD5 hash generator:

http://www.miraclesalad.com/webtools/md5.php
http://passwordsgenerator.net/md5-hash-generator/
http://www.md5.cz/

use the digest package

library(digest)
digest('12345678',  serialize = FALSE)

thanks for this example, it work's perfect in rstudio but when I put the code in my shinyserver folder to share it I have this error:
An error has occurred
The application failed to start.
The application exited during initialization.

I have other apps working, I tried with some suggestions from some blogs but it doesn't work.
Please help me

what is username and password for this password app

Can someone please explain the code in www\md5.js or maybe better just the idea behind it? What are the functions add32, cmn, ff, gg, hh, ii, ... doing?

Very good to share content！

Thanks for your effort, it saved alot of my time and gave me clear understanding as well ! (Y)

user name : withr
password: 12345678

We can use MD5 hash generator:

http://passwordsgenerators.net/md5-hash-generator