accessible from a web browser :-(
So should any of you folks want to map your iPhoto 'share' into webserver space, see
below for some code to play with (it is for a Pinnacle Showcenter, rather than a web
browser- but you'll get the gist).
Just looking to see if someone more into xml, stylesheets and templates (and some
clean MVC) gets an itch to code. (I am now having some fun with a Rendezvous
client which should soon detects all iBooks with open iPhoto share's in the house -
so any album appears by itself on the roster).
Dw
#!/usr/bin/perl # (c) Copyright 2003, Dirk-Willem van Gulik, All Rights Reserved, # See http://www.webweaving.org/LICENSE for details # [EMAIL PROTECTED] # # strings iPhotoDPA | grep ^/ # /containers /items /databases /server-info /login /update # # use strict; $|=1; use LWP::UserAgent; use Data::Dumper; use HTTP::Daemon; use HTTP::Status; use Image::Magick;
my $debug = 0; my $pinnacle = 1; # Server/laptop running iPhoto my $S = 'http://10.11.0.203:8770';
my $cache = '.cache'; die "Need $cache\n" unless -d $cache;
# Set up a web server:
my $server = HTTP::Daemon->new(
LocalPort => 8081,
ReuseAddr => 1,
ReusePort => 1,
Listen => 256
) || die;
my $url = $server->url;
print STDERR "Server: $url\n";my $ua = LWP::UserAgent->new;
# xxxx = base64(passwd); # GET dpap://dirkx:[EMAIL PROTECTED]:8770/login HTTP/1.1
my $q; my $r;
# See http://tapjam.net/daap/draft.html for details. # # Init and auth with the server, get a session # ID and then a list of albums (virtual and real). # $q = rq('/server-info'); $q = rq('/login'); my $sid = $q->{mlog}->[0]->{mlid}->[0];
$q = rq('/update?session-id='.$sid);
my $rid = $q->{mupd}->[0]->{musr}->[0];# $q=rq('/databases?session-id='.$sid);
$q=rq('/databases?session-id='.$sid.'&revsion-id='.$rid);my $dbid = $q->{avdb}->[0]->{mlcl}->[0]->{mlit}->[0]->{miid}->[0];
my $collection = $q->{avdb}->[0]->{mlcl}->[0]->{mlit}->[0]->{minm}->[0];# $q=rq('/databases/'.$dbid.'/containers/'.$rid.'/items?session- id='.$sid);
$q=rq('/databases/1/containers?session-id='.$sid.'&revsion-id='.$rid);
my @albums=();
my %albums=();
foreach my $s (@{$q->{aply}->[0]->{mlcl}->[0]->{mlit}}) {
my $pid = $s->{miid}->[0];
my $name = $s->{minm}->[0];
push @albums, $pid;
$albums{ $pid } = $name;
};print STDERR "Got ".(1+$#albums)." albums - ready to serve\n";
$SIG{PIPE} = 'IGNORE';while(my $c=$server->accept) {
while(my $r = $c->get_request) {
if ($r->method ne 'GET') {
$c->send_error(RC_FORBIDDEN);
next;
};
my $path= $r->url->path;
my $page;
print STDERR "Path: $path ";
my $h = HTTP::Headers->new('Content-type','text/html');
my $res;
if ($path eq '/bg.jpg') {
open(FH,'bg.jpg'); read(FH,$page,1024*1024*100); close(FH);
$res = HTTP::Response->new( 200, "Ok",
HTTP::Headers->new('Content-type','image/jpeg'),
$page);
} elsif ($path eq '/') {
$page=qq|
<meta SYABAS-FULLSCREEN>
<meta SYABAS-PHOTOTITLE=1>
<meta syabas-keyoption="caps">
<meta myibox-pip="32,288,176,112,1">
<body background="bg.jpg">
<h1>Collection: $collection</h1><ul>
<table align=right>|;
my $i = 0;
map {
$page .= '<tr><td width=40%></td>' if ($i % 3) == 0;
$page .= qq|<td width=20%><a href="/$_/">$albums{$_}</td>|;
$page .= '</tr>' if ($i % 3) == 2;
$i++;
} @albums;
$page .= '</tr>' unless ($i % 3);
$page .= "</table>";
$res = HTTP::Response->new( 200, "Ok", $h, $page);
}
elsif ($path =~ m|^/show/(\d+)|) {
my $pid = $1;
$page .= "100|100|Duh|$url\hires/$pid|\n";
$res = HTTP::Response->new( 200, "Ok",
HTTP::Headers->new('Content-type','text/plain'),
$page);
}
elsif ($path =~ m|^/play/(\d+)|) {
# generate pinnacle playlists.
my $pid = $1;
my $qq=rq('/databases/1/containers/'.$pid.'/items?session- id='.$sid.'&revsion-id='.$rid);
my $i = 0;
for my $t (@{$qq->{apso}->[0]->{mlcl}->[0]->{mlit}}) {
my $ppid = $t->{miid}->[0];
my $pname = $t->{minm}->[0];
$page .= "3|2|$pname|$url\hires/$ppid|\n";
};
$res = HTTP::Response->new( 200, "Ok",
HTTP::Headers->new('Content-type','text/plain'),
$page);
}
elsif ($path =~ m|^/(\d+)/|) {
my $pid = $1;
$page=qq|
<meta SYABAS-FULLSCREEN>
<meta SYABAS-PHOTOTITLE=1>
<meta syabas-keyoption="caps">
<meta myibox-pip="32,288,176,112,1">
<body background="bg.jpg">
<h1>Album: $albums{$pid} ($pid)</h1>
<table align=right>
<tr><td width=40%><a href="MUTE" pod="1,1,$url\play/$pid">play</a></td>|;
my $qq=rq('/databases/1/containers/'.$pid.'/items?session- id='.$sid.'&revsion-id='.$rid);
my $i = 0;
for my $t (@{$qq->{apso}->[0]->{mlcl}->[0]->{mlit}}) {
my $ppid = $t->{miid}->[0];
my $pname = $t->{minm}->[0];
$page .= '<tr><td width=40%></td>' if (($i % 3) == 0) && $i;
# Pinnacle specific
# $page .= qq|<td width=20% align=center valign=top><a href="MUTE" pod="1,1,$url\show/$ppid"><img src="/thumb/$ppid" border=0></a><br>$pname</td>|;
$page .= qq|<td width=20% align=center valign=top><a href="$url\hires/$ppid"><img src="/thumb/$ppid" border=0></a><br>$pname</td>|;
$page .= '</tr>' if ($i % 3) == 2 || $i == @albums;
$i++;
};
$page .= '</tr>' unless ($i % 3);
$page .= "</table>";
$res = HTTP::Response->new( 200, "Ok", $h, $page);
}
elsif ($path =~ m|^/(\w+)/(\d+)|) {
my $type = $1;
$type = 'thumb' unless ($type eq 'hires');
my $ppid = $2;
my $f = $cache .'/in-'.$type.'-'.$ppid.'.jpg';
my $F = $cache .'/out-'.$type.'-'.$ppid.'.jpg';
if (! -e $F) {
if (! -e $f) {
my $img = rq('/databases/1/items?session- id='.$sid.'&meta=dpap.'.$type.'&query=(\'dmap.itemid:'.$ppid.'\')');
# print Dumper($img);
$page = $img->{adbs}->[0]->{mlcl}->[0]->{mlit}->[0]->{pfdt}->[0];
open(FH,'>'.$f); print FH $page; close(FH);
}
my $p = new Image::Magick;
$p->Read($f);
if ($type eq 'thumb') {
$p->Mogrify('Scale', geometry => '100x100');
} else {
$p->Mogrify('Scale', geometry => '720x576');
}
# Map into something remotely not too ugly for display on a PAL telecsion screen.
$p->Mogrify('Quantize', 'colorspace' => 'YCbCr');
$p->Mogrify('Contrast', 'sharpen' => '1');
$p->Mogrify('Gamma', 'gamma' => 2.8 );
$p->Write($F);
undef $p;
}
open(FH,$F); read(FH, $page,128*1024*1024); close FH;
$res = HTTP::Response->new( 200, "Ok",
HTTP::Headers->new('Content-type','image/jpeg'),
$page);
} else {
$res = HTTP::Response->new( 401, "not found");
};
# this sucks - but Safari otherwise skips the first 2 images.
$c->force_last_request;
$c->send_response( $res );
print STDERR "served ".length($page)." bytes.\n";
}
$c->close;
undef $c;
}
exit;
sub rq() {
my $s = shift;
my $res = $ua->request( HTTP::Request->new(GET => $S.$s));
return die $! unless ($res->is_success);
decode(0,$res->content);
};sub decode() {
my ($p,$d)[EMAIL PROTECTED];
my %r=();
# Table with data types - passed to 'unpack' except for 'nest' which
# is simply recursive. See http://tapjam.net/daap/draft.html for details.
my %d = qw(
adbs nest
msrv nest
mlog nest
mupd nest
avdb nest
aply nest
mlit nest
mlit nest
mlcl nest
apso nest
mstt N4
musr N4
mlid N4
mstm N4
minm C*
mpro CCCC
ppro CCCC
mslr C
msal C
msau C
msdc N
muty N
mtca N
mtco N
mrco N
miid N
mper N
minm a*
mimc N
mctc N
pasp a*
pimf a*
pfdt a*
);
while(length($d) != 0) {
die unless length($d)>8;
my $h = substr($d,0,8); $d = substr($d,8);
my ($tag, $len) = unpack('a4N4', $h);
my $data = substr($d,0,$len); $d = substr($d,$len);
print ("\t" x $p) if $debug;
print "$tag $len " if $debug; my @v = ();
if (defined $d{ $tag }) {
if ($d{ $tag } eq 'nest') {
print "[\n" if $debug;
@v = (decode($p+1,$data) );
print ("\t" x $p) if $debug;
print "]" if $debug;
} else {
@v = unpack($d{ $tag },$data);
print "=".join(',',@v) if $debug;
}
} else {
print "\n" if $debug;
print ("\t" x $p) if $debug;
print " --<$data>--" if $debug;
@v = ($data);
};
print "\n" if $debug;
$r{ $tag } = () unless defined $r{$tag};
push @{ $r{ $tag } }, @v;
};
return \%r;
}
smime.p7s
Description: S/MIME cryptographic signature
