File: credential-api.R

package info (click to toggle)
r-cran-credentials 2.0.2-1
  • links: PTS, VCS
  • area: main
  • in suites: sid, trixie
  • size: 492 kB
  • sloc: makefile: 2; sh: 1
file content (182 lines) | stat: -rw-r--r-- 6,140 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
#' Retrieve and store git HTTPS credentials
#'
#' Low-level wrappers for the [git-credential](https://git-scm.com/docs/git-credential)
#' command line tool. Try the user-friendly [git_credential_ask]
#' and [git_credential_update] functions first.
#'
#' The [credential_fill] function looks up credentials for a given host, and
#' if none exists it will attempt to prompt the user for new credentials. Upon
#' success it returns a list with the same `protocol` and `host` fields as the
#' `cred` input, and additional `username` and `password` fields.
#'
#' After you have tried to authenticate the provided credentials, you can report
#' back if the credentials were valid or not. Call [credential_approve] and
#' [credential_reject] with the `cred` that was returned by [credential_fill]
#' in order to validate or invalidate a credential from the store.
#'
#' Because git credential interacts with the system password manager, the appearance
#' of the prompts vary by OS and R frontend.  Note that [credential_fill] should
#' only be used interactively, because it may require the user to enter credentials
#' or unlock the system keychain. On the other hand [credential_approve] and
#' [credential_reject] are non-interactive and could be used to save or delete
#' credentials in a scripted program. However note that some credential helpers
#' (e.g. on Windows) have additional security restrictions that limit use of
#' [credential_approve] and [credential_reject] to credentials that were actually
#' entered by the user via [credential_fill]. Here it is not possible at all to
#' update the credential store without user interaction.
#'
#' @export
#' @rdname credential_api
#' @name credential_api
#' @param cred named list with at least fields `protocol` and `host` and
#' optionally also `path`, `username` ,`password`.
#' @param verbose emit some useful output about what is happening
#' @examples \donttest{
#' # Insert example cred
#' example <- list(protocol = "https", host = "example.org",
#'   username = "test", password = "secret")
#' credential_approve(example)
#'
#' # Retrieve it from the store
#' cred <- credential_fill(list(protocol = "https", host = "example.org", path = "/foo"))
#' print(cred)
#'
#' # Delete it
#' credential_reject(cred)
#' }
credential_fill <- function(cred, verbose = TRUE){
  out <- credential_exec("fill", cred = cred, verbose = verbose)
  data <- strsplit(out, "=", fixed = TRUE)
  key <- vapply(data, `[`, character(1), 1)
  val <- vapply(data, `[`, character(1), 2)
  structure(as.list(structure(val, names = key)), class = 'git_credential')
}

#' @export
#' @rdname credential_api
#' @name credential_api
credential_approve <- function(cred, verbose = TRUE){
  credential_exec("approve", cred = cred, verbose = verbose)
  invisible()
}

#' @export
#' @rdname credential_api
#' @name credential_api
credential_reject <- function(cred, verbose = TRUE){
  credential_exec("reject", cred = cred, verbose = verbose)
  invisible()
}

credential_exec <- function(command, cred, verbose){
  input <- cred_to_input(cred)
  on.exit(unlink(input))
  if(is_windows() || is_macos() || !isatty(stdin())){
    text <- git_with_sys(c("credential", command), input = input, verbose = verbose)
    strsplit(text, "\n", fixed = TRUE)[[1]]
  } else {
    # base::system can freeze RStudio Desktop or Windows
    git_with_base(c("credential", command), input = input, verbose = verbose)
  }
}

git_with_base <- function(command, input = "", verbose = TRUE){
  git <- find_git_cmd()
  res <- system2(git, command, stdin = input,
                 stdout = TRUE, stderr = ifelse(isTRUE(verbose), "", TRUE))
  status <- attr(res, "status")
  if(length(status) && !identical(status, 0L)){
    stop(paste(res, collapse = "\n"))
  }
  res
}

git_with_sys <- function(command, input = NULL, verbose = TRUE){
  git <- find_git_cmd()
  outcon <- rawConnection(raw(0), "r+")
  on.exit(close(outcon), add = TRUE)
  timeout <- ifelse(interactive(), 120, 10)
  status <- sys::exec_wait(git, command, std_out = outcon, std_err = verbose,
                           std_in = input, timeout = timeout)
  if(!identical(status, 0L)){
    stop(sprintf("Failed to call 'git %s'", paste(command, collapse = " ")), call. = FALSE)
  }
  trimws(rawToChar(rawConnectionValue(outcon)))
}

find_git_cmd <- function(git = getOption("git", "git"), error = TRUE){
  if(cmd_exists(git)){
    return(git)
  }
  if(is_windows()){
    locations <- c("C:\\PROGRA~1\\Git\\cmd\\git.exe",
                   "C:\\Program Files\\Git\\cmd\\git.exe")
    for(i in locations){
      if(cmd_exists(i)){
        return(i)
      }
    }
  }
  if(error){
    stop(sprintf("Could not find the '%s' command line util", git), call. = FALSE)
  }
}

has_git_cmd <- function(){
  !is.null(find_git_cmd(error = FALSE))
}

parse_url <- function(url, allow_ssh = TRUE){
  out <- strsplit(url, "://", fixed = TRUE)[[1]]
  if(length(out) < 2){
    if(!isTRUE(allow_ssh)){
      stop(sprintf("URL must start with e.g. https:// (found %s)", url))
    } else {
      protocol = 'ssh'
      rest = url
    }
  } else {
    protocol <- out[1]
    rest <- out[2]
  }
  password <- NULL
  username <- if(grepl("^[^/]+@", rest)){
    auth <- strsplit(rest, "@", fixed = TRUE)[[1]]
    rest <- paste(auth[-1], collapse = "@")
    password <- if(grepl(":", auth[1], fixed = TRUE)){
      auth <- strsplit(auth[1], ":", fixed = TRUE)[[1]]
      paste(auth[-1], collapse = ":")
    }
    auth[1]
  }
  rest <- strsplit(rest, "/", fixed = TRUE)[[1]]
  host <- rest[1]
  path <- if(length(rest) > 1){
    paste(rest[-1], collapse = "/")
  }
  c(
    username = username,
    password = password,
    protocol = protocol,
    host = host,
    path = path
  )
}

cred_to_input <- function(data, input = tempfile()){
  str <- paste(names(data), as.character(data), collapse = "\n", sep = "=")
  writeBin(charToRaw(sprintf("%s\n", str)), con = input)
  return(input)
}

cmd_exists <- function(cmd){
  nchar(Sys.which(cmd)) > 0
}

is_windows <- function(){
  identical(.Platform$OS.type, "windows")
}

is_macos <- function(){
  identical(tolower(Sys.info()[['sysname']]), "darwin")
}