AC-MrGamoo

 view release on metacpan or  search on metacpan

lib/AC/MrGamoo/API/Client.pm  view on Meta::CPAN

sub _read {
    my $me  = shift;
    my $evt = shift;

    debug("recvd reply to $me->{info}");

    my($proto, $data, $content) = read_protocol_no_content( $me, $evt );
    return unless $proto;

    # check response
    if( $proto->{is_error} ){
        return $me->_uhoh("rcvd error response");
    }

    $proto->{data} = AC::MrGamoo::Protocol->decode_reply($proto, $data);
    debug("recvd reply to $me->{info} - $proto->{data}{status_code} $proto->{data}{status_message}");

    if( $proto->{data}{status_code} != 200 ){
        return $me->_uh_oh("recvd error reply $proto->{data}{status_code} $proto->{data}{status_message}");
    }

    $me->{result}    = $proto;
    $me->{status_ok} = 1;
    $me->shut();
}

sub _uh_oh {
    my $me  = shift;
    my $msg = shift;

    debug("error $msg");
    $me->run_callback('error', { error => $msg } );
    $me->shut();
}


1;

lib/AC/MrGamoo/API/Get.pm  view on Meta::CPAN

    my $io      = shift;
    my $proto   = shift;
    my $req     = shift;
    my $content = shift;

    my $file = filename($req->{filename});
    my $fd = $io->{fd};
    fcntl($fd, F_SETFL, 0);	# unset nbio

    return nbfd_reply(404, "not found", $fd, $proto, $req) unless -f $file;
    open(F, $file) || return nbfd_reply(500, 'error', $fd, $proto, $req);
    my $size = (stat($file))[7];
    my $sha1 = sha1_file($file);

    debug("get file '$file' size $size");

    # send header
    my $gb  = ACPScriblReply->encode( { status_code => 200, status_message => 'OK', hash_sha1 => $sha1 } );
    my $hdr = AC::MrGamoo::Protocol->encode_header(
        type		=> $proto->{type},
        msgidno		=> $proto->{msgidno},

lib/AC/MrGamoo/API/Put.pm  view on Meta::CPAN

    my($dir) = $file =~ m|^(.+)/[^/]+$|;

    # mkpath
    eval{ mkpath($dir, undef, 0755) };

    # open tmp
    my $tmp = "$file.tmp";
    unless( open(F, "> $tmp") ){
        problem("open file failed: $!");
        return nbfd_reply(500, 'error', $fd, $proto, $req);
    }

    # read + write
    my $size = $proto->{content_length};
    my $sha1 = $req->{hash_sha1};

    verbose("put file '$file' size $size");

    if( $content ){
        syswrite( F, $content );

lib/AC/MrGamoo/API/Put.pm  view on Meta::CPAN

    }

    eval {
        my $chk = AC::MrGamoo::Protocol->sendfile(\*F, $fd, $size, 10);
        close F;
        die "file size mismatch\n" unless (stat($tmp))[7] == $proto->{content_length};
        die "SHA1 check failed\n" if $sha1 && $sha1 ne $chk;
    };
    if(my $e = $@){
        unlink $tmp;
        verbose("error: $e");
        nbfd_reply(500, 'error', $fd, $proto, $req);
        return;
    }

    rename $tmp, $file;

    nbfd_reply(200, 'OK', $fd, $proto, $req);
}

1;

lib/AC/MrGamoo/API/Simple.pm  view on Meta::CPAN

        if( $gpid ){
            # parent
            _exit(0);
        }else{
            # orphaned child
            eval {
                $func->($io, $proto, $req, @_);
            };
            if(my $e = $@){
                chomp $e;
                verbose("child error: $e");
                _exit(1);
            }
            _exit(0);
        }
    }
}

1;

lib/AC/MrGamoo/API/Xfer.pm  view on Meta::CPAN

    my $x = AC::MrGamoo::Retry->new(
        newobj	=> \&_mk_xfer,
        newargs => [ $req ],
        tryeach	=> $req->{location},
       );

    # reply now
    if( $x ){
        reply( 200, 'OK', $io, $proto, $req );
    }else{
        debug("sending error, xfer/retrier failed, $io->{info}");
        reply( 501, 'Error', $io, $proto, $req );
    }

    # send status when finished
    $x->set_callback('on_success', \&_yippee, $proto, $req);
    $x->set_callback('on_failure', \&_boohoo, $proto, $req);

    # start
    $x->start();
}

lib/AC/MrGamoo/Kibitz/Client.pm  view on Meta::CPAN

    $me->{status_ok} = 1;

    eval {
        my $resp = AC::MrGamoo::Protocol->decode_reply( $proto, $data );
        for my $update ( @{$resp->{status}} ){
            AC::MrGamoo::Kibitz::Peers->update( $update );
        }
    };
    if(my $e = $@){
        verbose("error: $e");
    }
    $me->shut();
}

lib/AC/MrGamoo/Protocol.pm  view on Meta::CPAN

    my $io  = shift;
    my $evt = shift;

    if( length($io->{rbuffer}) >= $HDRSIZE && !$io->{proto_header} ){
        # decode header
        eval {
            $io->{proto_header} = __PACKAGE__->decode_header( $io->{rbuffer} );
        };
        if(my $e=$@){
            verbose("cannot decode protocol header: $e");
            $io->run_callback('error', {
                cause	=> 'read',
                error	=> "cannot decode protocol: $e",
            });
            $io->shut();
            return;
        }
    }

    return $io->{proto_header};
}

# for simple status queries, argus, debugging

lib/AC/MrGamoo/Submit/Compile.pm  view on Meta::CPAN

        if( $d->{tag} eq 'block'){
            $me->_add_block($tag, $me->_compile_block($tag));
        }
        elsif( $d->{tag} eq 'simple' ){
            $me->_add_block($tag, $me->_compile_block_simple($tag));
        }
        elsif( $d->{tag} eq 'config' ){
            $me->_add_config($tag, $me->_compile_config($tag));
        }
        else{
            $me->_die("syntax error");
        }
    }

    delete $me->{_lineno};
    delete $me->{_line};
    delete $me->{_fd};

    1;
}

lib/AC/MrGamoo/Submit/Compile.pm  view on Meta::CPAN

        last if $line =~ m|^</%$tag>\s*$|;

        my($tag) = $line =~ m|^<%(.*)>\s*$|;

        if( $BLOCK{$tag} eq 'simple' ){
            $b->{$tag} .= $me->_compile_block_simple( $tag );
            $b->{code} .= $me->_lineno_info();
        }elsif( $BLOCK{$tag} eq 'config' ){
            $b->{$tag} = $me->_compile_config( $tag );
        }elsif( $tag ){
            $me->_die("syntax error");

        }else{
            $b->{code} .= $line;
        }
    }

    return $b;
}

sub _compile_block_simple {

lib/AC/MrGamoo/Xfer.pm  view on Meta::CPAN

        unless( open( $fd, "> $tmpfile" ) ){
            verbose("cannot open output file '$tmpfile': $!");
            return;
        }

        my $chk  = _sendfile($oreq, $fd, $s, $size);
        my $sha1 = $p->{data}{hash_sha1};
        die "SHA1 check failed\n" if $sha1 && $sha1 ne $chk;
    };
    if(my $e=$@){
        debug("error: $e");
        return;
    }

    return $p;
}

sub _sendfile {
    my $req   = shift;
    my $out   = shift;
    my $in    = shift;