fix: re-establish the AMLink session when a reply cannot be decoded

An undecodable reply means the camera and this module no longer agree about
the session, but nothing put that right. Dahua_RPC re-logs-in only when it gets
a parseable error back, so rpc_call returning undef left the session poisoned:
in the logs a CoaxialControlIO.control failure is followed by every later
keepAlive and logout on that session failing the same way, until something else
forces a login. A light switched on by an alarm stays on for that whole period.

Split the single attempt out as rpc_once, recording why it failed, and have
rpc_call re-login and retry once when the failure was a decode failure on a
masked Request.

The guards matter more than the retry:
- bootstrap channels never recover, since login() issues them
- login() calls logout(), a Request on the dead session, so a re-entrancy guard
  stops its own decode failure starting another recovery
- one retry only, and a 5 second backoff, so a camera that always answers
  unreadably is not met with a login per command

refs #4423

Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com>
Claude-Session: https://claude.ai/code/session_01UvTCzCbvGt8xKQRNCSA7o8

scripts/ZoneMinder/lib/ZoneMinder/Control/AMLink.pm

@@ -172,8 +172,12 @@ sub open {
   return undef;
 }
 
-sub rpc_call {
+# One attempt, no recovery. Records why it failed in {last_failure} so the
+# caller can tell an undecodable reply (the session is probably gone) from an
+# HTTP error or a missing key (re-logging in would not help).
+sub rpc_once {
   my ($self, $method, $params, %opts) = @_;
+  $self->{last_failure} = undef;
   $self->{rpc_id} = ($self->{rpc_id} || 0) + 1;
 
   my $req = { method => $method, id => $self->{rpc_id}, params => $params };
@@ -192,6 +196,7 @@ sub rpc_call {
   # than saying what is actually wrong.
   if ($cmd_type eq 'Request' and !$key) {
     Error("AMLink: not logged in, refusing to send $method");
+    $self->{last_failure} = 'nokey';
     return undef;
   }
 
@@ -204,16 +209,19 @@ sub rpc_call {
   };
   if (!$res) {
     Error("AMLink: request failed for $method: ".log_safe($@));
+    $self->{last_failure} = 'transport';
     return undef;
   }
   if (!$res->is_success) {
     Error('AMLink: HTTP '.$res->status_line." for $method");
+    $self->{last_failure} = 'http';
     return undef;
   }
 
   my $cmd = extract_cmd($res->decoded_content(charset => 'none'));
   if (!defined $cmd) {
     Error("AMLink: no <cmd> element in the reply to $method");
+    $self->{last_failure} = 'nocmd';
     return undef;
   }
   my $raw_cmd = $cmd;
@@ -239,11 +247,70 @@ sub rpc_call {
       ($plain ? 'YES - the camera answered without masking' : 'no'),
       substr($raw_cmd, 0, 24), unpack('H*', substr($decoded, 0, 24))));
     return $plain if $plain;   # usable after all, so do not throw it away
+    $self->{last_failure} = 'decode';
     return undef;
   }
   return $data;
 }
 
+# How long to wait before trying to re-establish the session again. Without
+# this a camera that answers unreadably every time would be hit with a fresh
+# login on every command.
+use constant RECOVERY_BACKOFF => 5;
+
+# An undecodable reply means we and the camera no longer agree about the
+# session, and nothing in the old code put that right: Dahua_RPC only re-logs-in
+# when it gets a *parseable* error back, so rpc_call returning undef left the
+# session poisoned and every later command failed the same way. A light switched
+# on by an alarm would then stay on until something else forced a re-login.
+sub rpc_call {
+  my ($self, $method, $params, %opts) = @_;
+
+  my $data = $self->rpc_once($method, $params, %opts);
+  return $data if defined $data;
+
+  # Only a masked Request carries a session to lose. The bootstrap channels
+  # (Login, OutsideCmd, GetGeneralKey) run before one exists, and login() issues
+  # them, so recovering from those would recurse.
+  return undef if cmd_type_for($method, %opts) ne 'Request';
+  return undef if ($self->{last_failure} // '') ne 'decode';
+
+  # login() calls logout(), which is itself a Request on the poisoned session.
+  # Without this guard its decode failure would start another recovery.
+  return undef if $self->{recovering};
+
+  my $now = time;
+  if (defined $self->{last_recovery} and $now - $self->{last_recovery} < RECOVERY_BACKOFF) {
+    Debug(1, "AMLink: not re-establishing the session for $method, tried under "
+      .RECOVERY_BACKOFF.'s ago');
+    return undef;
+  }
+  $self->{last_recovery} = $now;
+
+  Info("AMLink: reply to $method could not be decoded, re-establishing the session");
+  local $self->{recovering} = 1;
+  # Drop what we have rather than letting logout() try to hand back a session
+  # the camera has evidently already forgotten.
+  $self->{session} = undef;
+  $self->{mask_key} = undef;
+
+  if (!$self->login()) {
+    Error("AMLink: could not re-establish the session after $method");
+    return undef;
+  }
+
+  # One retry only. Re-sending is safe for everything this module issues: the
+  # light commands set an absolute state rather than toggling, and getStatus and
+  # keepAlive are reads.
+  my $retry = $self->rpc_once($method, $params, %opts);
+  if (defined $retry) {
+    Info("AMLink: $method succeeded on the new session");
+  } else {
+    Error("AMLink: $method failed again after re-establishing the session");
+  }
+  return $retry;
+}
+
 # ZoneMinder::Logger writes one line per message and keeps only what precedes
 # the first newline, so anything appended after an embedded one is lost. Perl
 # error strings routinely carry a trailing newline and "at FILE line N." can be

scripts/ZoneMinder/t/amlink_transport.t

@@ -1,6 +1,7 @@
 use strict;
 use warnings;
-use Test::More tests => 50;
+use MIME::Base64;
+use Test::More tests => 66;
 
 require_ok('ZoneMinder::Control::AMLink');
 
@@ -183,3 +184,153 @@ is($log_safe->("a\r\nb"), 'a | b', 'CRLF counts as one break, not two');
 is($log_safe->('no newlines here'), 'no newlines here', 'an ordinary message is untouched');
 is($log_safe->(undef), '', 'undef yields an empty string rather than a warning');
 is($log_safe->(''), '', 'an empty message stays empty');
+
+# --- recovering from an undecodable reply ------------------------------------
+# An undecodable reply means we and the camera disagree about the session.
+# Dahua_RPC only re-logs-in when it gets a *parseable* error back, so before
+# this the session stayed poisoned and every later command failed the same way,
+# leaving a light switched on by an alarm on until something forced a re-login.
+
+{
+  package FakeRes;
+  sub new { my ($c, $body, $ok) = @_; bless {body => $body, ok => (defined $ok ? $ok : 1)}, $c }
+  sub is_success { $_[0]{ok} }
+  sub status_line { '500 Boom' }
+  sub decoded_content { $_[0]{body} }
+}
+{
+  package FakeUA2;
+  sub new { bless {queue => [], sent => []}, shift }
+  sub agent { }
+  sub post {
+    my $self = shift;
+    push @{$self->{sent}}, \@_;
+    my $r = shift @{$self->{queue}};
+    return defined $r ? $r : FakeRes->new('<body><cmd>####</cmd></body>');
+  }
+}
+
+my $tkey = $key_from_string->('KEY');
+# A reply the camera would send: json -> base64 -> masked with the session key.
+sub good_reply {
+  my $payload = $mask_data->($tkey, MIME::Base64::encode_base64('{"result":1,"id":1}', ''));
+  return FakeRes->new('<body><cmd>'.$payload.'</cmd></body>');
+}
+# '####' unmasks to bytes that are not base64, so nothing valid comes out.
+sub bad_reply { FakeRes->new('<body><cmd>####</cmd></body>') }
+
+my $logins;
+sub fresh_obj {
+  my %extra = @_;
+  my $ua = FakeUA2->new;
+  my $o = bless {
+    session => 's1', mask_key => $tkey, rpc_id => 0, host => 'h',
+    RPCBase => 'http://h/Onvif/device_service', ua => $ua, %extra,
+  }, $P;
+  return ($o, $ua);
+}
+
+$logins = 0;
+my $login_ok = 1;
+{
+  no strict 'refs'; no warnings 'redefine';
+  *{$P.'::login'} = sub {
+    my $self = shift;
+    $logins++;
+    return 0 if !$login_ok;
+    $self->{session} = 's2';
+    $self->{mask_key} = $tkey;
+    return 1;
+  };
+}
+
+# 1. a decode failure re-establishes the session and retries once
+{
+  my ($o, $ua) = fresh_obj();
+  @{$ua->{queue}} = (bad_reply(), good_reply());
+  $logins = 0;
+  my $r = $o->rpc_call('CoaxialControlIO.control', {channel => 0});
+  is($logins, 1, 'an undecodable reply triggers exactly one re-login');
+  is(scalar @{$ua->{sent}}, 2, 'and the command is sent again on the new session');
+  ok(defined $r, 'the retry result is returned to the caller');
+  is($o->{session}, 's2', 'the object is left holding the new session');
+}
+
+# 2. one retry only - it does not keep going
+{
+  my ($o, $ua) = fresh_obj();
+  @{$ua->{queue}} = (bad_reply(), bad_reply(), good_reply());
+  $logins = 0;
+  my $r = $o->rpc_call('CoaxialControlIO.control', {channel => 0});
+  is($logins, 1, 'a retry that also fails does not start another recovery');
+  is(scalar @{$ua->{sent}}, 2, 'exactly two attempts were made');
+  is($r, undef, 'and the caller is told it failed');
+}
+
+# 3. a failed re-login is reported rather than retried blindly
+{
+  my ($o, $ua) = fresh_obj();
+  @{$ua->{queue}} = (bad_reply(), good_reply());
+  $logins = 0; $login_ok = 0;
+  my $r = $o->rpc_call('CoaxialControlIO.control', {channel => 0});
+  is($r, undef, 'a failed re-login yields undef');
+  is(scalar @{$ua->{sent}}, 1, 'and the command is not resent');
+  $login_ok = 1;
+}
+
+# 4. only an undecodable reply counts - an HTTP error is not a lost session
+{
+  my ($o, $ua) = fresh_obj();
+  @{$ua->{queue}} = (FakeRes->new('', 0), good_reply());
+  $logins = 0;
+  $o->rpc_call('CoaxialControlIO.control', {channel => 0});
+  is($logins, 0, 'an HTTP error does not trigger a re-login');
+}
+
+# 5. the bootstrap channels must never recover: login() issues them
+{
+  my ($o, $ua) = fresh_obj();
+  @{$ua->{queue}} = (bad_reply(), good_reply());
+  $logins = 0;
+  $o->rpc_call('global.login', {}, login => 1);
+  is($logins, 0, 'a Login that fails to decode does not call login again');
+
+  ($o, $ua) = fresh_obj();
+  @{$ua->{queue}} = (bad_reply(), good_reply());
+  $logins = 0;
+  $o->rpc_call('LXSecurity.getGeneralKey', {});
+  is($logins, 0, 'nor does the key exchange');
+}
+
+# 6. no recursion: login() calls logout(), which is a Request on the dead
+# session. Without the guard its own decode failure starts another recovery.
+{
+  my ($o, $ua) = fresh_obj();
+  @{$ua->{queue}} = (bad_reply(), bad_reply(), bad_reply(), good_reply());
+  $logins = 0;
+  {
+    no strict 'refs'; no warnings 'redefine';
+    local *{$P.'::login'} = sub {
+      my $self = shift;
+      $logins++;
+      die "runaway recursion: login called $logins times\n" if $logins > 3;
+      $self->rpc_call('global.logout');      # the real login() does this
+      $self->{session} = 's2'; $self->{mask_key} = $tkey;
+      return 1;
+    };
+    my $r = eval { $o->rpc_call('CoaxialControlIO.control', {channel => 0}) };
+    is($@, '', 'a logout that fails inside login does not recurse');
+    is($logins, 1, 'login runs once, not once per nested failure');
+  }
+}
+
+# 7. backoff stops a camera that always answers unreadably from being hammered
+{
+  my ($o, $ua) = fresh_obj();
+  @{$ua->{queue}} = (bad_reply(), bad_reply(), bad_reply(), bad_reply());
+  $logins = 0;
+  $o->rpc_call('CoaxialControlIO.control', {channel => 0});
+  is($logins, 1, 'the first failure recovers');
+  $o->rpc_call('CoaxialControlIO.control', {channel => 0});
+  is($logins, 1, 'a second failure straight after does not log in again');
+}