持続可能な社会のための太陽光発電を推進しています。

http / httpsを使った通信 | Perlで作るサーバーサービス

Perlでhttp(s)プロトコルを利用した通信を行います。Webサービスの利用をオートメーション化したい際に利用出来ます。

IO::Socket::INET(SSL)を使って楽にHTTP(S)通信を行うためのユーティリティーモジュールです。ざっと、次のような特徴があります。

• HTTP / HTTPS 対応
• Port指定 対応
• GET / POST 対応
• application/x-www-form-urlencoded / multipart/form-data 対応
• Fileのフォーム送信 対応
• Redirect 対応
• Cookie 対応
• Basic認証 対応

HttpUtility.pm

package HttpUtility;
use Date::Parse;
use IO::Socket::INET;
use IO::Socket::SSL;
use MIME::Base64;
sub     new
{
my $class = shift;
my $self = {
header => "",
body => "",
cookie => {}
};
bless $self,$class;
return $self;
}
sub get
{
my($self) = shift;
my($type) = shift;
if($type eq "header"){return $self->{header};}
return $self->{body};
}
sub request
{
my($self) = shift;
my(
$url,                           # http(s)://(id:pass@)www.example.com(:443)/example.cgi?a=1&b=2
$method,                        # GET or POST
$encoding,                      # (With POST) null or multipart/form-data
$ref_data_hash,                 # (With POST) reference to hash {name,data}
$ref_file_hash,                 # (With multipart/form-data) reference to hash {name,file}
) = @_;
$method = "GET" unless defined $method;
my $boundary = "----------boundary";
my $data = "";
if($method eq "POST"){
if($encoding eq "multipart/form-data"){
for my $key (keys %{$ref_data_hash}){
my $value = $ref_data_hash->{$key};
$data.="--$boundary\r\n";
$data.="Content-Disposition: form-data; name=\"$key\"\r\n\r\n";
$data.=$value."\r\n";
}
for my $key (keys %{$ref_file_hash}){
my $file = $ref_file_hash->{$key};
if(-f $file){
my $filename = $file;
if( $filename =~ m/.*\/(.+)$/i ){
$filename = $1;
}
my $fdata;
open(IN,$file);
read(IN, $fdata, -s($file));
close(IN);
$data.="--$boundary\r\n";
$data.="Content-Disposition: form-data; name=\"$key\"; filename=\"$filename\"\r\n\r\n";
$data.=$fdata."\r\n";
}
}
$data.="--$boundary--";
}else{
for my $key (keys %{$ref_data_hash}){
my $value = $ref_data_hash->{$key};
$key =~ s/([^ 0-9a-zA-Z_\-\.])/"%".uc(unpack("H2",$1))/eg;
$key =~ s/ /+/g;
$value =~ s/([^ 0-9a-zA-Z_\-\.])/"%".uc(unpack("H2",$1))/eg;
$value =~ s/ /+/g;
$data .= "$key=$value&";
}
$data =~ s/\&$//;
}
}
my($prtc,$auth,$host,$port,$dir);
while(1){
if($url =~ /^(http|https):\/\/(?:(.+:.+)\@|)(.+?)(?::(\d+)|)(\/.*|)$/){
($prtc, $auth, $host, $port, $dir) = ($1, $2, $3, $4, $5);
}elsif( $url =~ /^\// && $host ne "" ){
$dir = $url;
}else{
die "Invalid URL";
}
if(!$port){
$port = getservbyname($prtc, "tcp");
}
if(!$dir){
$dir = "/";
}
my $socket;
if ($prtc eq "https"){
$socket = IO::Socket::SSL->new(PeerAddr => $host, PeerPort => $port) || die "$! $host:$port";
}else{
$socket = IO::Socket::INET->new (PeerAddr => $host, PeerPort => $port) || die "$! $host:$port";
}
print $socket("$method $dir HTTP/1.0\r\n");
print $socket("Host:$host\r\n");
print $socket("User-Agent: HttpUtility\r\n");
if($auth){
my $b64 = encode_base64($auth,'');
print $socket("Authorization: Basic $b64\r\n");
}
my @keys = keys($self->{cookie});
foreach my $key (@keys){
my $value = $self->{cookie}{$key};
if($value =~ /expires=(.+?);/){
if( time > str2time($1)){
delete($self->{cookie}{$key});
next;
}
}
if($value =~ /^(.+?);/){
$value = $1;
}
print $socket("Cookie: $key=$value\r\n");
}
if( $method eq "POST" ){
if($encoding eq "multipart/form-data"){
print $socket("Content-Type: multipart/form-data; boundary=$boundary\r\n");
}else{
print $socket("Content-Type: application/x-www-form-urlencoded\r\n");
}
print $socket("Content-Length: ".length($data)."\r\n");
print $socket("\r\n");
print $socket($data."\r\n");
print $socket("\r\n");
}else{
print $socket("\r\n");
}
my $receive = "";
while (<$socket>) {$receive .= $_;}
close($socket);
$receive =~ /^(.*?)\r\n\r\n(.*)$/s;
$self->{header} = $1;
$self->{body} = $2;
my @header = split(/(?:\r\n|\r|\n)/, $self->{header});
foreach my $str (@header){
if( $str =~ /^Cache-Control:\s*.*no-cache/ ){
$self->{cookie} = undef;
}
}
foreach my $str (@header){
if( $str =~ /^Set-Cookie:\s*(.+?)=(.+?)$/ ){
$self->{cookie}{$1} = $2;
}
}
die "invalid answer!" unless($receive =~ /^HTTP\/[0-9]+\.[0-9]+ ([0-9]{3}) ([^\r\n]*)\r?\n/s);
my $status = $1;
if($status == 200 ){
last;
}elsif($status =~ /30\d/){
if($status != 307 ){
$method = "GET"
}
if( $receive =~ /Location:\s+?(.+?)(\n|\r)/ ){
$url = $1;
$url =~ tr/+/ /;
$url =~ s/%([0-9a-fA-F][0-9a-fA-F])/pack("C", hex($1))/eg;
next;
}
die "Invalid Moved Status";
}else{
die "HTTP Error: Status $1($2)";
}
}
return $status;
}
1;

使い方。

#!/usr/bin/perl
use HttpUtility;
$http = HttpUtility->new();
$status = $http->request("https://www.example.com/");
print $http->get("header");
print "\n\n";
print $http->get();
$data{'login_id'} = 'account';
$data{'password'} = 'asdfghj';
$status = $http->request("https://www.example.com/login","POST","",\%data);

他に検討したほうが良いこと。

• 不正なリダイレクトへの対応
• ドメイン毎のCookie管理

「curlやwgetでいいじゃん」という向きもあろうことかと存じますが、その通りです。

• 車輪の再発明

SSL通信に失敗する場合は以下を確認してみて下さい。

• IO::SOCKET::SSLのエラーをルート証明書の設定更新で対処する
• SSL証明書なしにHTTPS通信を行う

• 物件募集
• 森林
• 機器紹介
• 輸入の手引き
• Perlで作るサーバーサービス
• NUCでLinux Server

QT SOLAR

宮城県仙台市太白区長町一丁目2-11

［運営者］

• 株式会社キューティーソーラー
• 宮城県仙台市太白区長町一丁目2-11

［発電所］

• QT SOLAR 愛島発電所
• QT SOLAR 下増田発電所
• QT SOLAR 北原東発電所
• QT SOLAR 長久良辺発電所
• QT SOLAR 白坂発電所
• QT SOLAR 清水沢発電所

本ウェブサイト上のQT SOLAR 発電所は、グループ会社の発電所も含まれます。