library(shiny) library(DBI) library(RPostgres) library(dplyr) library(DT) library(glue) pg_dsn <- Sys.getenv("PG_DSN", "") s3_bucket <- Sys.getenv("S3_BUCKET", "") s3_endpoint <- Sys.getenv("S3_ENDPOINT", Sys.getenv("AWS_S3_ENDPOINT", Sys.getenv("AWS_S3_ENDPOINT_URL", ""))) aws_access_key <- Sys.getenv("S3_ACCESS_KEY", Sys.getenv("AWS_ACCESS_KEY_ID", "")) aws_secret_key <- Sys.getenv("S3_SECRET_KEY", Sys.getenv("AWS_SECRET_ACCESS_KEY", "")) aws_cli <- Sys.getenv("AWS_CLI", "aws") thumb_prefix <- Sys.getenv("THUMB_PREFIX", "icu/thumbnails/") processed_prefix <- Sys.getenv("PROCESSED_PREFIX", "icu/processed/") entrance_prefix <- Sys.getenv("ENTRANCE_PREFIX", "icu/entrance/") processed_prefix <- Sys.getenv("PROCESSED_PREFIX", "icu/processed/") thumb_prefix <- Sys.getenv("THUMB_PREFIX", "icu/thumbnails/") inventory_table <- Sys.getenv("INVENTORY_TABLE", "") deployment_table <- Sys.getenv("DEPLOYMENT_TABLE", "") if (pg_dsn == "") { stop("PG_DSN env var is required") } if (s3_bucket == "") { stop("S3_BUCKET env var is required") } if (s3_endpoint == "") { stop("S3_ENDPOINT/AWS_S3_ENDPOINT env var is required") } if (aws_access_key == "" || aws_secret_key == "") { stop("S3_ACCESS_KEY/S3_SECRET_KEY or AWS_ACCESS_KEY_ID/AWS_SECRET_ACCESS_KEY required") } Sys.setenv( AWS_ACCESS_KEY_ID = aws_access_key, AWS_SECRET_ACCESS_KEY = aws_secret_key, AWS_EC2_METADATA_DISABLED = "true" ) parse_pg_dsn <- function(dsn) { if (grepl("^postgresql://", dsn)) { m <- regexec("^postgresql://([^:]+):([^@]+)@([^:/]+):?(\\d+)?/(.+)$", dsn) r <- regmatches(dsn, m)[[1]] if (length(r) == 0) stop("Invalid PG_DSN URL format") return(list( user = r[2], password = r[3], host = r[4], port = ifelse(r[5] == "", 5432, as.integer(r[5])), dbname = r[6] )) } if (grepl("host=", dsn)) { parts <- strsplit(dsn, "\\s+")[[1]] kv <- lapply(parts, function(p) strsplit(p, "=", fixed = TRUE)[[1]]) vals <- setNames(lapply(kv, `[`, 2), lapply(kv, `[`, 1)) return(list( user = vals$user, password = vals$password, host = vals$host, port = as.integer(vals$port), dbname = vals$dbname )) } return(list(dbname = dsn)) } pg <- parse_pg_dsn(pg_dsn) pg_con <- do.call(dbConnect, c(list(RPostgres::Postgres()), pg)) onStop(function() dbDisconnect(pg_con)) table_exists <- function(con, table_name) { res <- dbGetQuery(con, "SELECT to_regclass($1) AS t", params = list(table_name)) !is.na(res$t[1]) } fetch_cameras <- function() { if (inventory_table != "" && table_exists(pg_con, inventory_table)) { q <- glue("SELECT DISTINCT cam_id FROM {inventory_table} ORDER BY 1") return(dbGetQuery(pg_con, q)$cam_id) } character(0) } fetch_projects <- function() { if (deployment_table != "" && table_exists(pg_con, deployment_table)) { q <- glue("SELECT DISTINCT project FROM {deployment_table} ORDER BY 1") return(dbGetQuery(pg_con, q)$project) } character(0) } build_query <- function(from_date, to_date, camera_id, project_name, limit_rows, offset_rows, use_date_filter) { base <- " SELECT m.metadata_uuid, m.import_ts, m.ocr_ts, m.\"CustomerTimezone\", m.\"SignalStrength\", m.\"Temperature\", m.imei, m.servertime, ci.cam_id, d.project, c.category, c.score FROM remote_cam.metadata m LEFT JOIN cam_inventory ci ON ci.imei = m.imei LEFT JOIN LATERAL ( SELECT d.project FROM cam_deployments d WHERE d.camera_id = ci.cam_id AND m.servertime >= d.deployment_start AND (d.deployment_end IS NULL OR m.servertime < d.deployment_end) ORDER BY d.deployment_start DESC NULLS LAST LIMIT 1 ) d ON TRUE LEFT JOIN LATERAL ( SELECT category, score FROM remote_cam.category c WHERE c.image_uuid = m.metadata_uuid ORDER BY score DESC NULLS LAST LIMIT 1 ) c ON TRUE " params <- list() if (camera_id != "" && inventory_table != "" && table_exists(pg_con, inventory_table)) { base <- paste0(base, " WHERE ci.cam_id = $", length(params) + 1) params <- append(params, list(camera_id)) } if (project_name != "" && deployment_table != "" && table_exists(pg_con, deployment_table)) { prefix <- if (length(params) == 0) " WHERE " else " AND " base <- paste0(base, prefix, " m.imei IN (SELECT ci2.imei FROM cam_inventory ci2 JOIN ", deployment_table, " d ON d.camera_id = ci2.cam_id WHERE d.project = $", length(params) + 1, ")") params <- append(params, list(project_name)) } if (camera_id == "" && project_name == "" && !use_date_filter) { base <- paste0(base, " ORDER BY m.import_ts DESC LIMIT $", length(params) + 1, " OFFSET $", length(params) + 2) params <- append(params, list(as.integer(limit_rows), as.integer(offset_rows))) return(list(sql = base, params = params)) } if (use_date_filter) { prefix <- if (length(params) == 0) " WHERE " else " AND " base <- paste0(base, prefix, " m.import_ts >= $", length(params) + 1, " AND m.import_ts < $", length(params) + 2) params <- append(params, list(from_date, to_date)) } base <- paste0(base, " ORDER BY m.import_ts DESC LIMIT $", length(params) + 1, " OFFSET $", length(params) + 2) params <- append(params, list(as.integer(limit_rows), as.integer(offset_rows))) list(sql = base, params = params) } normalize_endpoint <- function(url) { if (url == "") return("") u <- url if (!grepl("^https?://", u)) { u <- paste0("https://", u) } sub("/+$", "", u) } s3_endpoint <- normalize_endpoint(s3_endpoint) if (aws_access_key == "" || aws_secret_key == "" || s3_endpoint == "") { stop("S3_ACCESS_KEY/S3_SECRET_KEY or AWS_ACCESS_KEY_ID/AWS_SECRET_ACCESS_KEY and S3_ENDPOINT are required") } normalize_endpoint <- function(url) { if (url == "") return("") u <- url if (!grepl("^https?://", u)) { u <- paste0("https://", u) } sub("/+$", "", u) } s3_endpoint <- normalize_endpoint(s3_endpoint) cache_dir <- Sys.getenv("THUMB_CACHE_DIR", "/tmp/thumb_cache") dir.create(cache_dir, recursive = TRUE, showWarnings = FALSE) addResourcePath("thumbs", cache_dir) presigned_url <- function(key, expires = 600) { if (is.null(key) || is.na(key) || key == "") return(NULL) key <- sub(paste0("^", s3_bucket, "/"), "", key) cmd <- sprintf( "\"%s\" --endpoint-url %s s3 presign s3://%s/%s --expires-in %d", aws_cli, s3_endpoint, s3_bucket, key, as.integer(expires) ) tryCatch({ out <- system(cmd, intern = TRUE) if (length(out) == 0) return(NULL) out[1] }, error = function(e) { message(sprintf("[DEBUG] presign error: %s", e$message)) NULL }) } cache_thumbnail <- function(uuid) { if (is.null(uuid) || is.na(uuid)) return(NULL) local_path <- file.path(cache_dir, paste0(uuid, ".jpg")) if (file.exists(local_path)) return(local_path) key <- paste0(thumb_prefix, uuid, ".jpg") cmd <- sprintf( "\"%s\" --endpoint-url %s s3 cp s3://%s/%s \"%s\" --only-show-errors", aws_cli, s3_endpoint, s3_bucket, key, local_path ) tryCatch({ system(cmd, ignore.stdout = TRUE, ignore.stderr = TRUE) if (file.exists(local_path)) return(local_path) NULL }, error = function(e) { message(sprintf("[DEBUG] cache thumb error: %s", e$message)) NULL }) } ui <- fluidPage( titlePanel("MelesICU - Image Browser"), tags$script(HTML(" function melesThumbClick(el){ var uuid = el.getAttribute('data-uuid'); if(uuid){ Shiny.setInputValue('thumb_click', uuid, {priority: 'event'}); } } var melesScrollLock = false; window.addEventListener('scroll', function() { if (melesScrollLock) return; var nearBottom = (window.innerHeight + window.scrollY) >= (document.body.offsetHeight - 200); var canLoad = Shiny && Shiny.shinyapp && Shiny.shinyapp.$outputValues && Shiny.shinyapp.$outputValues.has_more_flag; var isLoading = Shiny && Shiny.shinyapp && Shiny.shinyapp.$outputValues && Shiny.shinyapp.$outputValues.loading_flag; if (nearBottom && canLoad && !isLoading) { melesScrollLock = true; Shiny.setInputValue('scroll_load', Date.now(), {priority: 'event'}); setTimeout(function(){ melesScrollLock = false; }, 1000); } }); ")), sidebarLayout( sidebarPanel( dateRangeInput("date_range", "Datum", start = Sys.Date() - 7, end = Sys.Date()), checkboxInput("use_date_filter", "Datumsfilter aktiv", value = TRUE), selectInput("camera_id", "Kamera (cam_id)", choices = c("ALL", fetch_cameras()), selected = "ALL"), selectInput("project_name", "Projekt", choices = c("ALL", fetch_projects()), selected = "ALL"), numericInput("limit_rows", "Eintraege pro Seite", value = 20, min = 10, max = 2000, step = 10), numericInput("page", "Seite", value = 1, min = 1, step = 1), fluidRow( column(6, actionButton("prev_page", "Zurueck")), column(6, actionButton("next_page", "Vor")) ), actionButton("apply_filters", "Filter anwenden") ), mainPanel( tags$style(HTML(" .spinner { margin: 20px 0; width: 32px; height: 32px; border: 4px solid #ddd; border-top-color: #333; border-radius: 50%; animation: spin 1s linear infinite; } @keyframes spin { to { transform: rotate(360deg); } } ")), conditionalPanel("output.loading_flag", tags$div(class = "spinner")), uiOutput("debug_info"), uiOutput("thumb_grid") ) ) ) server <- function(input, output, session) { rv <- reactiveValues(data = NULL, selected = NULL, loading = FALSE, has_more = TRUE, debug = NULL) cache_env <- new.env(parent = emptyenv()) cache_keys <- character(0) url_cache_env <- new.env(parent = emptyenv()) url_cache_keys <- character(0) load_data <- function() { from_date <- as.POSIXct(input$date_range[1], tz = "UTC") to_date <- as.POSIXct(input$date_range[2] + 1, tz = "UTC") cam <- ifelse(input$camera_id == "ALL", "", input$camera_id) proj <- ifelse(input$project_name == "ALL", "", input$project_name) page <- max(1, as.integer(input$page)) limit <- as.integer(input$limit_rows) offset <- (page - 1) * limit key <- paste(from_date, to_date, cam, proj, input$use_date_filter, limit, offset, sep = "|") if (exists(key, envir = cache_env, inherits = FALSE)) { rv$data <- get(key, envir = cache_env, inherits = FALSE) return(invisible(NULL)) } q <- build_query(from_date, to_date, cam, proj, limit, offset, input$use_date_filter) rv$loading <- TRUE on.exit({ rv$loading <- FALSE }, add = TRUE) data <- dbGetQuery(pg_con, q$sql, params = q$params) assign(key, data, envir = cache_env) cache_keys <<- c(cache_keys, key) if (length(cache_keys) > 20) { drop <- head(cache_keys, length(cache_keys) - 20) for (k in drop) rm(list = k, envir = cache_env) cache_keys <<- tail(cache_keys, 20) } rv$data <- data rv$has_more <- nrow(data) >= limit # Batch prefetch first 10 thumbnails in parallel if (!is.null(data) && nrow(data) > 0) { uuids <- head(data$metadata_uuid, 10) tryCatch({ parallel::mclapply(uuids, cache_thumbnail, mc.cores = 4) }, error = function(e) { message(sprintf("[DEBUG] prefetch error: %s", e$message)) }) } if (!is.null(data) && nrow(data) > 0) { sample_uuid <- data$metadata_uuid[1] thumb_key <- paste0(thumb_prefix, sample_uuid, ".jpg") url <- presigned_url(thumb_key) rv$debug <- list( count = nrow(data), sample_uuid = sample_uuid, thumb_key = thumb_key, url = url ) message(sprintf("[DEBUG] count=%d sample_uuid=%s thumb_key=%s url=%s", nrow(data), sample_uuid, thumb_key, ifelse(is.null(url), "NULL", url))) } else { rv$debug <- list(count = 0) message("[DEBUG] count=0") } } observeEvent(input$apply_filters, { if (rv$loading) { showNotification("Noch am Laden – bitte warten.", type = "message") return(NULL) } load_data() }, ignoreInit = TRUE) observeEvent(input$prev_page, { if (rv$loading) return(NULL) new_page <- max(1, as.integer(input$page) - 1) updateNumericInput(session, "page", value = new_page) load_data() }, ignoreInit = TRUE) observeEvent(input$next_page, { if (rv$loading) return(NULL) new_page <- as.integer(input$page) + 1 updateNumericInput(session, "page", value = new_page) load_data() }, ignoreInit = TRUE) observeEvent(input$scroll_load, { if (rv$loading || !rv$has_more) return(NULL) new_page <- as.integer(input$page) + 1 updateNumericInput(session, "page", value = new_page) load_data() }, ignoreInit = TRUE) observeEvent(TRUE, { if (rv$loading) return(NULL) load_data() }, once = TRUE) output$loading_flag <- reactive({ rv$loading }) outputOptions(output, "loading_flag", suspendWhenHidden = FALSE) output$has_more_flag <- reactive({ rv$has_more }) outputOptions(output, "has_more_flag", suspendWhenHidden = FALSE) format_cet <- function(ts) { if (is.null(ts) || is.na(ts)) return("-") format(as.POSIXct(ts, tz = "CET"), "%Y-%m-%d %H:%M:%S %Z") } format_ts <- function(ts) { if (is.null(ts) || is.na(ts)) return("-") format(as.POSIXct(ts, tz = "CET"), "%Y-%m-%d %H:%M:%S %Z") } format_diff <- function(server_ts, camera_ts) { if (is.null(server_ts) || is.na(server_ts) || is.null(camera_ts) || is.na(camera_ts)) return("-") secs <- as.numeric(difftime(server_ts, camera_ts, units = "secs")) sign <- ifelse(secs >= 0, "+", "-") secs <- abs(secs) hh <- floor(secs / 3600) mm <- floor((secs %% 3600) / 60) ss <- floor(secs %% 60) sprintf("%s%02d:%02d:%02d", sign, hh, mm, ss) } output$thumb_grid <- renderUI({ dat <- rv$data if (is.null(dat) || nrow(dat) == 0) { return(tags$div("Keine Ergebnisse.")) } cards <- lapply(seq_len(nrow(dat)), function(i) { row <- dat[i, ] local_path <- cache_thumbnail(row$metadata_uuid) if (is.null(local_path)) return(NULL) url <- paste0("thumbs/", basename(local_path)) tags$div( style = "display:inline-block; width: 220px; margin: 6px; vertical-align: top;", tags$div(class = "ph", style = "width: 220px; height: 220px; background:#eee; display:block;"), tags$img( src = url, style = "width: 220px; height: 220px; object-fit: cover; display:block; cursor: pointer;", loading = "lazy", onload = "this.parentNode.querySelector('.ph').style.display='none';", `data-uuid` = row$metadata_uuid, onclick = "melesThumbClick(this)" ), tags$div(style = "font-size: 12px; color: #222;", glue("CamID: {row$cam_id}")), tags$div(style = "font-size: 12px; color: #444;", glue("Serverzeit: {format_cet(row$servertime)}")), tags$div(style = "font-size: 12px; color: #444;", glue("Kamerazeit: {format_ts(row$ocr_ts)}")), tags$div(style = "font-size: 12px; color: #444;", glue("AI classification: {row$category} ({row$score})")), { delta <- format_diff(row$servertime, row$ocr_ts) delta_secs <- if (delta == "-") NA else as.numeric(difftime(row$servertime, row$ocr_ts, units = "secs")) is_warn <- !is.na(delta_secs) && abs(delta_secs) > 600 style <- if (is_warn) "font-size: 12px; color: #c00; font-weight: bold;" else "font-size: 12px; color: #444;" tags$div(style = style, glue("Delta: {delta}")) } ) }) tags$div(cards) }) output$debug_info <- renderUI({ if (is.null(rv$debug)) return(NULL) cnt <- rv$debug$count if (is.null(cnt)) return(NULL) if (cnt == 0) { return(tags$div(style = "font-size:12px; color:#a00; margin-bottom:8px;", "Debug: 0 Treffer.")) } tags$div(style = "font-size:12px; color:#555; margin-bottom:8px;", glue("Debug: Treffer={cnt}, Sample UUID={rv$debug$sample_uuid}"), tags$br(), glue("Thumb-Key: {rv$debug$thumb_key}"), tags$br(), if (!is.null(rv$debug$url)) tags$a(href = rv$debug$url, "Sample Thumbnail (Link)", target = "_blank") else "Sample URL: NULL") }) observeEvent(input$thumb_click, { uuid <- input$thumb_click dat <- rv$data if (is.null(dat)) return(NULL) row <- dat[dat$metadata_uuid == uuid, ] if (nrow(row) != 1) return(NULL) full_key <- paste0(processed_prefix, row$metadata_uuid, ".jpg") presigned_cached <- function(key, expires = 600) { now <- Sys.time() if (exists(key, envir = url_cache_env, inherits = FALSE)) { entry <- get(key, envir = url_cache_env, inherits = FALSE) if (is.list(entry) && !is.null(entry$expires_at) && now < entry$expires_at) { return(entry$url) } } u <- presigned_url(key, expires = expires) if (!is.null(u)) { assign(key, list(url = u, expires_at = now + expires - 30), envir = url_cache_env) url_cache_keys <<- c(url_cache_keys, key) if (length(url_cache_keys) > 200) { drop <- head(url_cache_keys, length(url_cache_keys) - 200) for (k in drop) rm(list = k, envir = url_cache_env) url_cache_keys <<- tail(url_cache_keys, 200) } } u } url <- presigned_cached(full_key) if (is.null(url)) { showModal(modalDialog( title = glue("Bild {uuid}"), "Full image nicht gefunden.", easyClose = TRUE, footer = NULL )) return(NULL) } showModal(modalDialog( title = glue("Bild {uuid}"), tags$img(src = url, style = "max-width: 100%; height: auto;"), easyClose = TRUE, footer = modalButton("Schließen"), size = "l" )) }) } shinyApp(ui, server)