%# The main dispatcher for RT/Atom 0.3
<%INIT>
require RT::Atom;

# needs discussion on using MD5(pass) as Digest token
@RT::AtomAuthenticationMethods = qw( WSSE Basic RT )
    unless @RT::AtomAuthenticationMethods;

my $realm = $RT::rtname;

$realm =~ s/[^\w.]//g;
my $nonce = Digest::MD5::md5_hex($realm . rand());
my %methods = map {($_ => 1)} @RT::AtomAuthenticationMethods;

my %accept = map { $_ => 1 } $r->headers_in->{'Accept'} =~ m{([^\s,]+/[^;,]+)}g;
my @encodings = $r->headers_in->{'Accept-Charset'} =~ m{([^\s,]+[^;,]*)}g;
my $atom_client = $accept{'application/x.atom+xml'};

my $header_out = sub { $r->headers_out->add(@_) };

my $http_charset;
if (@encodings) {
    require Encode;
    my $is_fatal = 1;
    foreach my $encoding (@encodings) {
	$is_fatal = 0 if $encoding eq '*';
	my $enc = Encode::find_encoding($encoding) or next;
	if ($enc->name eq 'utf8') {
	    $is_fatal = 0;
	    last;
	}
	$http_charset = $encoding;
	$m->notes('encoding', $encoding);
	last;
    }
    return $m->comp('Elements/Error', Status => 406) if $is_fatal and !$http_charset;
}
$http_charset ||= 'UTF-8';

$header_out->(
    'WWW-Authenticate' => qq(WSSE realm="$realm", profile="UsernameToken")
) if $methods{WSSE} and $atom_client;
$header_out->(
    'WWW-Authenticate' => qq(Digest realm="$realm", stale=false, nonce="", qop="auth", algorithm="MD5")
) if $methods{Digest} and !$atom_client;
$header_out->(
    'WWW-Authenticate' => qq(Basic realm="$realm")
) if $methods{Basic} and !$atom_client;

my $CurrentUser;

my $headerParts = sub {
    my $header = $r->headers_in->{$_[0]} || $ENV{$_[0]};
    $header =~ s/^(?:$_[1]) /", / or return;
    $header =~ s/"\s*$//; # strip whitespaces after the last "

    my %parts;
    foreach my $chunk (split /,\s*/, $header) {
	my ($k, $v) = split /=/, $chunk, 2;
	$v =~ s/^"//;
	$v =~ s/"$//;
	$parts{lc($k)} = $v;
    }
    $parts{lc($_)} = delete $parts{$_} for map "$_", keys %parts;
    return \%parts;
};

AUTH_Basic: {
    last if $CurrentUser or !$methods{Basic};

    ($r->headers_in->{'Authorization'} || $ENV{'Authorization'})
         =~ /^Basic (.+)$/ or last;
    my ($username, $password) = split(/:/, MIME::Base64::decode_base64($1), 2);

    require RT::CurrentUser;
    $CurrentUser = RT::CurrentUser->new;
    $CurrentUser->Load($username) or last;
    $CurrentUser->IsPassword($password) or undef $CurrentUser;
}

AUTH_Digest: {
    last if $CurrentUser or !$methods{Digest};

    my $parts = $headerParts->('Authorization', 'Digest') or last;

    my ($username, $auth_digest, $auth_nonce,
	$auth_nc, $auth_cnonce, $auth_qop, $auth_uri)
	= map { defined($_) ? $_ : last AUTH_Digest }
	    @{$parts}{qw(username response nonce nc cnonce qop uri)};

    # XXX validate $auth_uri

    require RT::CurrentUser;
    $CurrentUser = RT::CurrentUser->new;
    $CurrentUser->Load($username) or last;

    my $server_pass = $CurrentUser->UserObj->__Value('Password');
    $server_pass = unpack('H*', MIME::Base64::decode_base64("$server_pass=="))
	if length($server_pass) == 22;

    my $a1 = Digest::MD5::md5_hex("$username:$realm:$server_pass");

    $auth_digest eq Digest::MD5::md5_hex(
	join(
	    ":", 
	    $a1, $auth_nonce,
	    $auth_nc, $auth_cnonce, $auth_qop,
	    Digest::MD5::md5_hex($r->method . ":" . $auth_uri),
	)
    ) or undef $CurrentUser;
}

AUTH_WSSE: {
    last if $CurrentUser or !$methods{WSSE};
    my $wsse = $headerParts->('X-WSSE', qr/WSSE|UsernameToken/) or last;

    my ($username, $auth_digest, $auth_nonce, $auth_created)
	= map { defined($_) ? $_ : last AUTH_WSSE }
	    @{$wsse}{qw(username passworddigest nonce created)};

    require RT::CurrentUser;
    $CurrentUser = RT::CurrentUser->new;
    $CurrentUser->Load($username) or last;

    # check against reused nonces
    require MIME::Base64;
    $auth_nonce = MIME::Base64::decode_base64($auth_nonce);

    my $nonce_cache;
    require Cache::FileCache;
    $nonce_cache = Cache::FileCache->new({
	namespace => 'RT-Nonces',
	default_expires_in => 86400,
	auto_purge_interval => 3600,
    });
    $auth_nonce = substr($auth_nonce, 0, 32);
    (undef($CurrentUser), last) if $nonce_cache->get( $auth_nonce );

    # if ($auth_created and abs($auth_created - time) >= 864000) {
    #	last; # system clock differ by more than one day, oops!
    # }

    my $server_pass = $CurrentUser->UserObj->__Value('Password');
    $server_pass = unpack('H*', MIME::Base64::decode_base64("$server_pass=="))
	if length($server_pass) == 22;

    my $my_digest = MIME::Base64::encode_base64(Digest::SHA1::sha1(
	$auth_nonce .
	$auth_created .
	Digest::MD5::md5_hex("$username:$realm:$server_pass")
    ));

    chomp($auth_digest);
    chomp($my_digest);
    if ($auth_digest ne $my_digest) {
	undef $CurrentUser;
	last;
    }

    # remember issued nonces
    $nonce_cache->set( $auth_nonce, 1 );
}

AUTH_RT: {
    last if $CurrentUser or !$methods{RT} or $atom_client;
    $m->comp('/Elements/SetupSessionCookie', %ARGS);
    $CurrentUser = delete $session{CurrentUser};
}

# Now for the dreaded "su anotheruser" feature...
my $su = $r->headers_in->{'X-RT-CurrentUser'};
if ($CurrentUser and $su and ($su ne $CurrentUser->Id) and ($su ne $CurrentUser->Name)) {
    # You have to be SuperUser to do this.
    $CurrentUser->UserObj->HasRight(
	Right => 'SuperUser',
        Object => $RT::System,
    ) or return $m->comp('Elements/Error', Status => 406);

    $CurrentUser->Load($su);
}

if (!$CurrentUser or !$CurrentUser->Id) {
    return $m->comp('Elements/Error', Status => 401);
}

$session{CurrentUser} = $CurrentUser;
my $lang = $CurrentUser->LanguageHandle->language_tag;
$lang = "en, $lang" unless $lang =~ /^en\b/;

$header_out->('X-RT-CurrentUser', $CurrentUser->Id);
$header_out->('Content-Language', $lang);

my %Methods = (
    GET	    => 'Get',
    HEAD    => 'Get',
    POST    => 'Add',
    PUT	    => 'Set',
    DELETE  => 'Remove',
    OPTIONS => 'Describe',
);

my $method = $r->method;

my $path = $m->notes('dhandler_arg') || $m->dhandler_arg;
$path =~ s{/+(?:index\.html)?$}{}g;

my $user_method;
$method = $user_method = $1 if $path =~ s/!(\w+)$//;

my ($type, @parts) = grep length, split('/', $path);
$type =~ s{-}{::}g;
my $property;
$property = $1 if $type =~ s/\.(\w+)$//;

my $verb = $Methods{$method} or return $m->comp(
    'Elements/Error',
    Status => 405,
    Allow => join(', ', sort keys %Methods)
);

my $map;
$map = $m->comp('Elements/Introspect', Want => 'TopLevelCollections') if $type;

my $BaseURI = "$RT::WebPath/Atom/0.3";

my $class;
foreach my $key (@$map) {
    if ($key eq $type) {
	$class = $type = $key;
	$type =~ s/::/-/g;
	last;
    }

    if ($key =~ /\b\Q$type\E$/i) {
	$class = $type = $key;
	$type =~ s/::/-/g;
	$method =~ /^(?:GET|HEAD|OPTIONS)$/ or last;

	# Redirect "safe" methods.
	$path = join('/', $type, @parts);
	$path .= "!$user_method" if $user_method;
	my $uri = URI->new("$BaseURI/$path");
	$uri->query_form( $m->request_args );
	$header_out->(Location => $uri->as_string);
	return $m->comp('Elements/Error', Status => 301);
    }
}

$ARGS{Path} = $path;
$ARGS{BaseURI} = $BaseURI;
$ARGS{ShowLink} = "/Atom/0.3/Elements/Link";
$ARGS{ShowEntry} = "/Atom/0.3/Elements/Entry";
$ARGS{ShowError} = "/Atom/0.3/Elements/Error";
$ARGS{Now} = RT::Date->new($session{CurrentUser});
$ARGS{Now}->SetToNow;

my @types = qw(
    application/x.atom+xml
    application/xml
);
my $content_type = 'text/xml'; # fallback
foreach my $try_type (@types) {
    $accept{$try_type} or next;
    $content_type = $try_type;
    last;
}

$r->content_type("$content_type; charset=$http_charset");
$session{AtomClient} = $atom_client;

if (!$class) {
    return $m->comp('index', %ARGS) if $path =~ /index|^\W*$/i;
    return $m->comp('Elements/Error', Status => 404);
}

my $list = $class->new($session{CurrentUser});
$list->UnLimit;

my ($obj, $prev_obj);

foreach my $part (@parts) {
    if ($part =~ /^(\*(-)?)?(\d+)(?:\.(\w+))?$/) {
        my $id = $2 . $3;
	$property = $4;

	if ($1) {
	    if ($id < 0) {
		$obj = $list->ItemsArrayRef->[$id];
	    }
	    else {
		$list->GotoItem($id);
		$obj = $list->Next;
	    }
	    return $m->comp('Elements/Error', Status => 404) if !$obj;
	}
	else {
	    $obj = $list->NewItem;
	    $obj->Load($id);
	}
    }
    elsif ($part =~ /^(\w*)(?:\.(\w+))?$/ and !$obj) {
	$property = $2;
	$obj = $list->NewItem;

        # XXX exception
        if ($obj->can('LoadUserDefinedGroup')) {
            $obj->LoadUserDefinedGroup($1);
        }
        else {
            $obj->Load($1);
        }
    }
    elsif ($part =~ /^([A-Z]\w*)(?:\.(\w+))?$/) {
	$obj->can($1) or return $m->comp('Elements/Error', Status => 404);

	$list = $obj->$1;

	if ( ($property = $2) or !$list->can('UnLimit') ) {
	    $obj = $list;
	    undef $list;
	}
	else {
	    $prev_obj = $obj;
	    $property = $obj = undef;
	}
    }

    return $m->comp('Elements/Error', Status => 404)
	if $obj and $obj->can('Id') and !$obj->Id;
}

$obj ||= $list if $property;

my $resource = ($obj ? $property ? 'Property' : 'Object' : 'Container');

eval { $prev_obj = $obj if $obj };
eval { $obj ||= $list->NewItem };
eval { $obj->_expire( $obj->_gen_primary_cache_key()) };
eval { $list->UnLimit unless $list->_isLimited };

if ($resource eq 'Container') {
    # FeedURI on collection
    $verb = 'Search' if $verb eq 'Get';
}
elsif ($resource eq 'Object') {
    # PostURI on object
    $verb = 'Update' if $verb eq 'Add';
}

if (my $encoding = $m->notes('encoding')) {
    $m->notes(ToUTF8 => sub {
	Encode::_utf8_off($_[0]);
	Encode::from_to($_[0], $encoding, 'UTF-8');
    });
}
else {
    $m->notes(ToUTF8 => sub { 1 });
}

$m->comp(
    "$verb/index", %ARGS,
    Type => $type,
    Resource => $resource,
    Object => $prev_obj || $obj,
    Collection => $list,
    Property => $property,
    CollectionClass => ref($list),
    FeedURI => "$BaseURI/$type",
    X => XML::Simple->new(RootName => 'body', NoIndent => 0),
);
</%INIT>
<%FILTER>
if (my $encoding = $m->notes('encoding')) {
    require Encode;
    s/encoding="UTF-8"/encoding="$encoding"/;
    Encode::_utf8_off($_);
    Encode::from_to($_, 'UTF-8', $encoding, Encode::FB_XMLCREF());
}
</%FILTER>
<%FLAGS>
inherit	=> undef
</%FLAGS>
