#!/usr/bin/perl -w

use strict;
use warnings;

package Cyrus::SyncClient;

use Authen::SASL qw(Perl);
use IO::Socket::INET;
use MIME::Base64;
use Digest::SHA1;

my $digest = Digest::SHA1->new();

sub new {
  my $class = shift;
  my ($server, $username, $password) = @_;

  die "Need an server, username and password" unless
    ($server and $username and $password);

  my $Self = bless {
    verbose => 0,  
  }, ref($class) || $class;

  $Self->{sync_server} = $server; # IO::Socket::INET compatible
  $Self->{sync_username} = $username;
  $Self->{sync_password} = $password;

  # connect here
  $Self->connect();

  return $Self;
}

sub connect {
  my $Self = shift;
  my $mustexist = shift;

  unless ($Self->{sync_io}) {
    die "NEED TO BE CONNECTED ALREADY" if $mustexist;
    my $mech = 'DIGEST-MD5';
    my $user = $Self->{sync_username};
    my $server = $Self->{sync_server};
    my $pass = $Self->{sync_password};
    my $sasl = Authen::SASL->new(
      mechanism => $mech,
      callback => {
        user => $user,
        pass => $pass,
        auth => $user,
        realm => $server,
      },
    );
    
    my $io = IO::Socket::INET->new("$server:2005");
    my $conn = $sasl->client_new('csync', $server);
  
    my $info = $io->getline();
    my $banner = $io->getline();
  
    my $val = $conn->client_start() || '';
    $io->printf("AUTHENTICATE %s %s\r\n", $mech, MIME::Base64::encode_base64($val, ''));
  
    for (1..2) {
      my $step = $io->getline();
      my $val = MIME::Base64::decode_base64(substr($step, 2));
      my $res = $conn->client_step($val) || '';
      $io->print(MIME::Base64::encode_base64($res, '') . "\r\n");
    }
  
    my $res = $io->getline();
    die "Connection failed $res" unless $res =~ m{^OK};

    $Self->{sync_io} = $io;
  }

  return $Self->{sync_io};
}

sub user {
  my $Self = shift;
  my $user = shift;

  $Self->iowrite("USER", qv($user));

  my ($folders, $subs) = eval { $Self->_parse_mailboxes() };
  if ($@) {
    # initialise empty, we're nuking the user
    $folders = {};
    $subs = {};
    $Self->iocmd('RESET', qv($user));
  }
  
  return ($folders, $subs);
}

sub mailboxes {
  my $Self = shift;
  my @mailboxes = shift;

  $Self->iowrite("MAILBOXES", map { qv($_) } @mailboxes);

  my ($folders) = $Self->_parse_mailboxes();

  return $folders;
}

sub _parse_mailboxes {
  my $Self = shift;
  my $io = $Self->connect(1);

  my $folder;
  my %folders;
  my %subscribed;

  while (my $line = $io->getline()) {
    my @items = split_quoted($line);

    if ($items[0] eq 'OK') {
      last;
    }

    # handle folders
    # ** 12718d1747aed682 fastmail.fm!user.movetest_brong "admin  lrswipkxtecda   movetest_brong@fastmail.fm      lrswipkxtecd    anyone  p       " 1202640514 1 1 1 10240
    elsif ($items[0] eq '**') {
      $folder = $items[2];
      $folders{$folder} = {
        uniqueid => $items[1],
        foldername => $items[2],
        acl => $items[3],
        uidvalidity => $items[4] || time(),
        lastuid => $items[5] || 0,
        highestmodseq => $items[6] || 1,
        options => $items[7],
        quota => $items[8],
        contents => {},
      };
    }
  
    # handle uids
    # * 1 1 615a754f19e463512796b8d847b2c53a1aa70304 ()
    elsif ($items[0] eq '*') {
      my $uid = $items[1];
      $folders{$folder}{contents}{$uid} = {
        uid => $items[1],
        modseq => $items[2],
        guid => $items[3],
        flags => pf($items[4]),
      };
    }

    elsif ($items[0] eq '***') {
      $subscribed{$items[1]} = 1;
    }

    else {
      die "ODD LINE $line\n";
    }
  }

  return (\%folders, \%subscribed);
}

sub lock {
  my $Self = shift;
  $Self->iocmd('LOCK');
}

sub unlock {
  my $Self = shift;
  $Self->iocmd('UNLOCK');
}

sub reset {
  my $Self = shift;
  my $user = shift;

  $Self->iocmd('RESET', qv($user));
}

sub delete {
  my $Self = shift;
  my $mailbox = shift;

  $Self->iocmd('DELETE', qv($mailbox));
}

sub create {
  my $Self = shift;
  my $mailbox = shift;
  my $args = shift;

  # needed for generating the uniqueid
  my $uidvalidity = exists $args->{uidvalidity} ? $args->{uidvalidity} : time();

  my $partition = exists $args->{partition} ? $args->{partition} : 'default';
  my $acl = exists $args->{acl} ? $args->{acl} : user_acl(mailbox_user($mailbox));
  my $unqid = exists $args->{uniqueid} ? $args->{uniqueid} : make_uniqueid($mailbox, $uidvalidity);
  my $mbtype = exists $args->{mbtype} ? $args->{mbtype} : 0;
  my $options = exists $args->{options} ? $args->{options} : 1;

  $Self->iocmd('CREATE', qv($mailbox), qv($partition), qv($unqid), qv($acl), int($mbtype), int($options), int($uidvalidity));
}

sub setquota {
  my $Self = shift;
  my $mailbox = shift;
  my $quota = shift;

  $Self->iocmd('SETQUOTA', qv($mailbox), int($quota));
}

sub select {
  my $Self = shift;
  my $mailbox = shift;

  $Self->iocmd('SELECT', qv($mailbox));
}

sub expunge {
  my $Self = shift;
  my $mailbox = shift;
  my @uids = @_;

  $Self->iocmd('EXPUNGE', qv($mailbox), map { int($_) } @uids);
}

sub setflags {
  my $Self = shift;
  my $data = shift;

  my @items = map { int($_) => qf($data->{$_}) }
              sort { $a <=> $b } keys %$data;
  
  $Self->iocmd('SETFLAGS', @items);
}

sub uidlast {
  my $Self = shift;
  my $lastuid = shift;
  my $lastupdate = shift;

  $Self->iocmd('UIDLAST', int($lastuid), int($lastupdate));
}

sub setseen {
  my $Self = shift;
  my $user = shift;
  my $mailbox = shift;
  my $args = shift;

  my $seen = exists $args->{seen} ? $args->{seen} : '';
  my $lastupdate = exists $args->{lastupdate} ? $args->{lastupdate} : time();
  my $lastuid = exists $args->{lastuid} ? $args->{lastuid} : maxuid($seen);
  my $lastread = exists $args->{lastread} ? $args->{lastread} : $lastupdate;

  $Self->iocmd('SETSEEN', qv($user), qv($mailbox), int($lastread), int($lastuid), int($lastupdate), qv($seen));
}

sub addsub {
  my $Self = shift;
  my $user = shift;
  my $mailbox = shift;

  $Self->iocmd('ADDSUB', qv($user), qv($mailbox));
}

sub delsub {
  my $Self = shift;
  my $user = shift;
  my $mailbox = shift;

  $Self->iocmd('DELSUB', qv($user), qv($mailbox));
}

sub upload {
  my $Self = shift;
  my $lastuid = shift;
  my $lastupdate = shift;
  my $alldata = shift;

  my @cmd;
  foreach my $uid (sort keys %$alldata) {
    my $data = $alldata->{$uid};
    my $body = $data->{body} || die "Need a body\n";

    my $guid = $data->{guid} || make_guid($body);
    my $internaldate = exists $data->{internaldate} ? $data->{internaldate} : time();
    my $sentdate = exists $data->{sentdate} ? $data->{sentdate} : $internaldate;
    my $lastupdate = exists $data->{lastupdate} ? $data->{lastupdate} : time();
    my $modseq = exists $data->{modseq} ? $data->{modseq} : 1;
    my $flags = exists $data->{flags} ? $data->{flags} : {};

    push @cmd, 'SIMPLE', qv($guid), int($uid), int($internaldate), int($sentdate), int($lastupdate), 
               int($modseq), qf($flags), ref($body) ? $body : "{" . length($body) . "+}\r\n$body";
  }

  if (@cmd) {
    $Self->iocmd('UPLOAD', int($lastuid), int($lastupdate), @cmd);
  }
  else {
    $Self->uidlast($lastuid, $lastupdate);
  }
}

sub iowrite {
  my $Self = shift;
  my $io = $Self->connect();
  my @list = @_;
  if ($Self->{verbose}) {
    my $cstr = join(' ', @list);
    $cstr = substr($cstr, 0, 80) . '...' if length($cstr) > 83;
    print "IO: $cstr\n";
  }
  while (defined(my $item = shift @list)) {
    if (ref($item)) {
      seek($item, 0, 2);
      my $size = tell($item);
      seek($item, 0, 0);
      $io->print("{$size+}\r\n");
      sendfile($item, $io, $size);
    }
    else {
      $io->print($item);
    }
    if (@list) {
      $io->print(" ");
    }
  }
  $io->print("\r\n");
}

sub iocmd {
  my $Self = shift;
  $Self->iowrite(@_);
  my $io = $Self->connect(1);
  my $res = $io->getline();
  die "iocmd failed @_ => $res" unless $res =~ m{^OK};
}

# helpers

sub split_quoted {
  my $line = shift;
  my @items;
  while ($line ne '') {
    # quoted "mailbox with spaces"
    if ($line =~ s{^\"([^\"]+)\"\s*}{}) {
      push @items, $1;
    }
    # quoted (flag flag2 flag3)
    elsif ($line =~ s{^\(([^\)]*)\)}{}) {
      push @items, $1;
    }
    # regular atom
    elsif ($line =~ s{^([^\"]\S*)\s*}{}) {
      push @items, $1;
    }
    else {
      die "Odd $line";
    }
  }
  return @items;
}

sub qv {
  my $value = shift;

  if ($value eq '' or $value =~ m/\s/) {
    return qq{"$value"};
  }
  else {
    return $value;
  }
}

sub qf {
  my $value = shift || {};
  my @items = map { $value->{$_} } 
              grep { $_ ne "\\seen" and $_ ne "\\recent" }
              sort keys %$value;
  return "(" . join(' ', @items) . ")";
}

sub pf {
  my $value = shift || '';
  return { map { lc($_) => $_ } split(/ /, $value) };
}

sub make_uniqueid {
  my $name = shift;
  my $uidvalidity = shift;

  # #define PRIME (2147484043UL)
  # void mailbox_make_uniqueid(char *name, unsigned long uidvalidity, char *uniqueid, size_t outlen)
  # {
  #   unsigned long hash = 0;
  #   while (*name) {
  #     hash *= 251;
  #     hash += *name++;
  #     hash %= PRIME;
  #   }
  #   snprintf(uniqueid, outlen, "%08lx%08lx", hash, uidvalidity);
  # }

  my $PRIME = 2147484043;
  my $hash = 0;
  foreach my $char (split //, $name) {
    $hash *= 251;
    $hash += ord($char);
    $hash %= $PRIME;
  }
  return sprintf("%08lx%08lx", $hash, $uidvalidity);
}

sub maxuid {
  my $seen = shift;
  if ($seen =~ m/(\d+)$/) {
    return $1;
  }
  return 0;
}

sub make_guid {
  my $body = shift;

  $digest->reset();
  if (ref($body)) {
    seek($body, 0, 0);
    $digest->addfile($body);
  }
  else {
    $digest->add($body);
  }
  return $digest->hexdigest();
}

sub sendfile {
  my $src = shift;
  my $dest = shift;
  my $bytes = shift;

  while ($bytes > 0) {
    my $buf;
    my $todo = $bytes > 4096 ? 4096 : $bytes;
    my $n = $src->read($buf, $todo);
    unless ($n) {
      die "Failed to send file with $bytes remaining";
    }
    $dest->write($buf, $n);
    $bytes -= $n;
  }
}

sub user_acl {
  my $user = shift;
  return "admin\tlrswipkxtecda\t$user\tlrswipkxtecd\tanyone\tp\t";
}

sub mailbox_user {
  my $mailbox = shift;
  my $domain;
  if ($mailbox =~ s/^([^\!]+)\!//) {
    $domain = $1;
  }
  die "not a user folder" unless $mailbox =~ m/^user\.([^\.]+)/;
  return $domain ? "$1\@$domain" : $1;
}

1;