From: Jan Michel Date: Mon, 22 May 2017 09:02:55 +0000 (+0200) Subject: Add new version of power supply web GUI, formerly in daqtools/web/htdocs/tools/pwr X-Git-Url: https://jspc29.x-matter.uni-frankfurt.de/git/?a=commitdiff_plain;h=aebbb6fbaecc731e1970fb1c634d119b9cc24290;p=labtools.git Add new version of power supply web GUI, formerly in daqtools/web/htdocs/tools/pwr --- diff --git a/powersupplies/web/htdocs/build_index.pl b/powersupplies/web/htdocs/build_index.pl new file mode 100755 index 0000000..0683b2a --- /dev/null +++ b/powersupplies/web/htdocs/build_index.pl @@ -0,0 +1,67 @@ +#!/usr/bin/perl -w +use Cwd; + +if ($ENV{'SERVER_SOFTWARE'} =~ /HTTP-?i/i) { + &htsponse(200, "OK"); + } +print "Content-type: text/html\n\n"; + + + +my $pwd = &Cwd::cwd(); + +my $file = "pwr.conf"; +if ($ENV{'SERVER_SOFTWARE'} =~ /HTTPi/i) { + $file = "htdocs/".$file; + } + + +open(LESEN,$file) + or die "Fehler beim oeffnen von : $!\n"; + +while(defined(my $i = )) { + + if( $i =~ /^PWRSPLY:([^:]+):([^:]+):([^:]+):([^:]+):([^:]+)/g ) { + my @arr = split(':',$i); + shift @arr; + my $ser_dev = shift @arr; + my $speed = shift @arr; + my $dev_id = shift @arr; + my $type = shift @arr; + my $channels = shift @arr; + my $names = join(':',@arr); + +if($type eq "PSP") { +print < + +

+EOF +} + +if($type =~ /HMP/ or $type =~ /HMC/ or $type =~ /PST/) { +print < + +

+EOF +} + +if($type =~ /PWRSW/) { +print < + +

+EOF +} + + + } +} + + + +#print "CWD: ".$pwd."
(for debug)\n"; + + +return true; diff --git a/powersupplies/web/htdocs/index.html b/powersupplies/web/htdocs/index.html new file mode 100644 index 0000000..a3b834c --- /dev/null +++ b/powersupplies/web/htdocs/index.html @@ -0,0 +1,86 @@ + + + + + + + Access all POWER! + + + + +

Basic power supply control

+

+Platzhalter +

+ + + +

+Note that you need to have libdevice-serialport-perl or perl-Device-SerialPort
+installed and that the /dev/ttyUSBn need to be accessible by normal users.
+Feel free to alter the config file to accommodate your needs!
+Please don't use the # character to comment out lines
+Tested with HMC8043, HMP4040, HMP4030, PSP405, PSP2010, PST3202, PWRSW +

+//PWRSPLY:/path/to/device:Speed:Name:Type:Channels
+//PWRSPLY:IP0.0.0.0:Port:Name:Type:Channels
+PWRSPLY:/dev/ttyUSB0:9600:PST3202:PST:3
+PWRSPLY:/dev/ttyUSB0:115200:HMP4030:HMP:3
+PWRSPLY:IP192.168.0.56:5050:HMP4040:HMP:4
+PWRSPLY:/dev/FTDI_FT232R_USB_UART_AH02HFZW:2400:PSP2010:PSP:1
+PWRSPLY:/dev/FTDI_FT232R_USB_UART_A900LJXB:0:Desk:PWRSW:4
+
+ +
+ + + + + +

+ + + + + + + + + + + + + diff --git a/powersupplies/web/htdocs/pwr.conf b/powersupplies/web/htdocs/pwr.conf new file mode 100644 index 0000000..578af96 --- /dev/null +++ b/powersupplies/web/htdocs/pwr.conf @@ -0,0 +1,15 @@ +//PWRSPLY:/path/to/device:speed:Name:Type:Channels +//type can be HMP, HMC, PSP, PST + +//PWRSPLY:/dev/ttyUSB0:9600:PST3202:PST:3 +//PWRSPLY:/dev/ttyUSB0:115200:HMP4030:HMP:3 +//PWRSPLY:IP192.168.0.56:5050:HMP4040:HMP:4 +PWRSPLY:/dev/FTDI_FT232R_USB_UART_AH02HFZW:2400:PSP2010:PSP:1 +//PWRSPLY:/dev/FTDI_FT232R_USB_UART_A702HE33:2400:PSP405:PSP:1 +//PWRSPLY:IP192.168.0.56:5050:HMP4040 DiRich:HMP:4:LP1:LP2:LP3:DCDC +PWRSPLY:/dev/FTDI_Xmatter_TTL_ALR1AJS:57600:Desk:PWRSW:6:TestAdrian:Pulser:::TrgDistr:ADC +//PWRSPLY:SERpi@192.168.0.230/dev/FTDI_FT232R_USB_UART_AH02HFZW:2400:PSP2010:PSP:1 +//PWRSPLY:SERpi@192.168.0.230/dev/TRB3_Power48_00002:0:Rack48:PWRSW:4:Crate::: +//PWRSPLY:/dev/HAMEG_HO732_VCP023842636:0:HMP4040:HMP:4 +//PWRSPLY:IP192.168.0.56:5050:HMP4040 DiRich:HMP:4:LP1:LP2:LP3:DCDC +//PWRSPLY:/dev/TRB3_Power48_00002:0:Rack48:PWRSW:4:Desk::: diff --git a/powersupplies/web/htdocs/pwr.pl b/powersupplies/web/htdocs/pwr.pl new file mode 100755 index 0000000..00eb3d6 --- /dev/null +++ b/powersupplies/web/htdocs/pwr.pl @@ -0,0 +1,245 @@ +#!/usr/bin/perl -w +if ($ENV{'SERVER_SOFTWARE'} =~ /HTTP-?i/i) { + &htsponse(200, "OK"); + } +print "Content-type: text/html\n\n"; + + +use strict; +use warnings; +# use Device::SerialPort; +use IO::Socket; +use IO::Handle; +use feature 'state'; +use URI::Escape; +use Time::HiRes qw( usleep); +use POSIX qw/floor ceil strftime/; +use Fcntl; +use Storable qw(lock_store lock_retrieve); + +my $envstring = $ENV{'QUERY_STRING'}; +$envstring =~ s/%20/ /g; + + +my @new_command = split('&',$envstring); +my $ser_dev = shift(@new_command); +my $ser_type = shift(@new_command); +my $ser_speed = shift(@new_command); #speed or port number + +if (!defined $ser_dev || !defined $ser_type || !defined $ser_speed) { + exit 0; + } + + +my $port; +my $isIP = 0; +my $cnt = 0; +my $isRemote = undef; + +# Load stored values +my $file = $ser_dev; + $file =~ s/\W//g; + $file = "/dev/shm/pwrsup-".$file.".dump"; +my $db; +if(-e $file && -r $file) { + $db = lock_retrieve($file); + } + + +if($ser_dev =~ /^IP(.*)/) { + $ser_dev = $1; + $isIP = 1; + } +# elsif($ser_dev =~ /^SER(.*)/) { +# my $str = $1; +# ($isRemote,$ser_dev) = split('/',$str,2); +# $ser_dev = '/'.$ser_dev; +# } +else { + if ($ser_speed != 0){ + my $command = "stty -F $ser_dev speed $ser_speed"; + $command .= " -ixoff " if $ser_type eq 'PSP'; + my $res = qx($command); + } + } + +# if(defined $isRemote) { +# my $env = $ENV{'QUERY_STRING'}; +# $env =~ s/&/!/g; +# my $cmd = "bash -c \"ssh $isRemote 'QUERY_STRING=".$env." perl'\" write("$command\r"); + getValue($fh,$command,$cnt++); + #print "i sent the command: $command"; + #print "\n\nokay.\n"; + usleep 1E5; + } + + + my %state_lookup = ( + 0 => 'off', + 1 => 'on' ); + + my $a = getValue($fh,"L",$cnt++,1); + if ($a =~ m/V(\d\d\.\d\d)A(\d\.\d\d\d)W(\d\d\d\.\d)U(\d\d)I(\d\.\d\d)P(\d\d\d)F(\d\d\d\d\d\d)/) { + my $c_volt = $1; + my $c_cur = $2; + my $c_pwr = $3; + my $l_volt = $4; + my $l_cur = $5; + my $l_pwr = $6; + my $state_string = $7; + my $relais_state = $state_lookup{substr $state_string, 0,1}; + printf(" + + + + + + + + + + + +
%2.2f V +
%1.3f A +
%3.1f W +
voltage limit: %d V +
current limit: %1.2f A +
power limit: %d W +
output relais: $relais_state
" + ,$c_volt,$c_cur,$c_pwr,$l_volt,$l_cur,$l_pwr); + } +} + +sub PWRSW_serial { + print strftime("%H:%M:%S &", localtime()); + my $fh; + if(-e $ser_dev && -w $ser_dev) { + sysopen($fh, $ser_dev, O_RDWR|O_NDELAY) or die $!; + } + else { print "Device not found"; return;} + + while ( my $command = shift(@new_command) ) { + $command = uri_unescape($command); + my $x = getValue($fh,$command,$cnt++); + if ($command =~ /\?/) { + if ($x =~ /^\w[a-f0-9]{3}/) {print hex(substr($x,1,3)).'&';} + elsif ($x =~ /^\w[a-f0-9]{2}/) {print hex(substr($x,1,2)).'&';} +# else {print '&';} + } + } + close $fh; + return; + } + + +sub HMP_serial { + print strftime("%H:%M:%S &", localtime()); + my $fh; + if(-e $ser_dev && -w $ser_dev) { + sysopen($fh, $ser_dev, O_RDWR|O_NDELAY) or die $!; + } + else { print "Device not found"; return;} + + while ( my $command = shift(@new_command) ) { + $command = uri_unescape($command); + my $x = getValue($fh,$command,$cnt++); + $x =~ s/\&//; + print $x."&" if $command =~ /\?/; + usleep(40000) if $ser_type eq "PST"; + } + close $fh; + return; + } + + + +sub HMP_ethernet { + print strftime("%H:%M:%S &", localtime()); + + my $port = IO::Socket::INET->new(PeerAddr => $ser_dev, PeerPort => $ser_speed, Proto => "tcp", Type => SOCK_STREAM, Timeout => 1) + or (print("Device not found") && return); + + while ( my $command = shift(@new_command) ) { + $command = uri_unescape($command); + my $x = getValue($port,$command,$cnt++); + $x =~ s/\&//; + print $x."&" if $command =~ /\?/; + } + return; + } + + +sub serial_rw { + my ($fh, $command,$forceread) = @_; + my $x = ""; + if ($ser_type eq 'PSP') {$command .= "\r";} else {$command .= "\n";} + print $fh "$command"; + if($ser_type eq 'PWRSW' || $forceread || $command =~ /\?/) { + for my $i (0..500) { + $x .= <$fh>; + if($x && ($x =~ /\n/ || $x =~ /\r/) ) { + chomp $x; + last; + } + usleep(1000); + } + } + return $x; + } + + +sub getValue { + my ($fh,$cmd,$cnt,$forceread) = @_; + if (0 && defined $db->{$cmd.$cnt}{tim} && $db->{$cmd.$cnt}{tim} > time()-2) { + return $db->{$cmd.$cnt}{val}; + } + else { + my $val = serial_rw($fh,$cmd,$forceread); + addDB($cmd.$cnt,$val); + return $val; + } + } + + +sub addDB { + my ($cmd,$val) = @_; + $db->{$cmd}{val} = $val; + $db->{$cmd}{tim} = time(); + } + +lock_store($db,$file); +print "\n"; + +exit 1; + + + + diff --git a/powersupplies/web/htdocs/pwr_hmp.htm b/powersupplies/web/htdocs/pwr_hmp.htm new file mode 100644 index 0000000..edf020f --- /dev/null +++ b/powersupplies/web/htdocs/pwr_hmp.htm @@ -0,0 +1,237 @@ + + + + + + +Power Supply Monitor and Access + + + + +

Power Supply Access

+ + + +
+ +
Chan 1Chan 2Chan 3Chan 4 +
Voltage [V] + + + + + +
Actual[V/A] + + + + + +
Limits[V/A] + + + + + +
Output Relais + + + + +
Global Switch + +
Enable read-back of values +Read settings +
  +
+
+ + + + diff --git a/powersupplies/web/htdocs/pwr_psp.htm b/powersupplies/web/htdocs/pwr_psp.htm new file mode 100644 index 0000000..004d682 --- /dev/null +++ b/powersupplies/web/htdocs/pwr_psp.htm @@ -0,0 +1,161 @@ + + + + + + +Power Supply Monitor and Access + + + + +

Power Supply Access

+ + + + + + + + + + + + + + + + +
Readings: Settings:
+ + +
+		 + +
+ + + + +
Voltage [V] + +
+
Voltage limit [V] + +
Current limit [A] + +
Power limit [W] + +
Save settings to EEPROM +
+ +
Output Relais +
+
Enable read-back of values. +
+
+ +
+ + + + + + diff --git a/powersupplies/web/htdocs/pwr_switch.htm b/powersupplies/web/htdocs/pwr_switch.htm new file mode 100644 index 0000000..3b84c0b --- /dev/null +++ b/powersupplies/web/htdocs/pwr_switch.htm @@ -0,0 +1,159 @@ + + + + + + +Power Supply Monitor and Access + + + + +

+ + + +
+ + + + + +
ChannelStatusCurrentAverageLimit + +
Enable read-back of values + +
  +
+
+ + + + diff --git a/powersupplies/web/htdocs/save_conf.pl b/powersupplies/web/htdocs/save_conf.pl new file mode 100755 index 0000000..46118be --- /dev/null +++ b/powersupplies/web/htdocs/save_conf.pl @@ -0,0 +1,30 @@ +#!/usr/bin/perl -w + +if ($ENV{'SERVER_SOFTWARE'} =~ /HTTP-?i/i) { + &htsponse(200, "OK"); + } +print "Content-type: text/html\n\n"; + + +my $envstring = $ENV{'QUERY_STRING'}; +$envstring =~ s/%20/ /g; +$envstring =~ s/&/\n/g; +##$envstring =~ s/&/\n/g; + + +my $file = "pwr.conf"; +if ($ENV{'SERVER_SOFTWARE'} =~ /HTTPi/i) { + $file = "htdocs/".$file; + } + + +open(SCHREIBEN,">$file") + or print "Fehler beim oeffnen von : $!\n"; + +print SCHREIBEN $envstring; +close(SCHREIBEN); + +print "saved!"; + + +return true; diff --git a/powersupplies/web/htdocs/scripts.js b/powersupplies/web/htdocs/scripts.js new file mode 100644 index 0000000..3e2a5c1 --- /dev/null +++ b/powersupplies/web/htdocs/scripts.js @@ -0,0 +1,44 @@ + + +function getdata(command,callback,option) { + var xmlhttp = null; + var cb = null; + xmlhttp=new XMLHttpRequest(); + cb = callback; + + xmlhttp.onreadystatechange = function() { + if(xmlhttp.readyState == 4) { + if(cb && option) + cb(xmlhttp.responseText,option); + else if(cb) + cb(xmlhttp.responseText); + } + } + xmlhttp.open("GET",command,true); + xmlhttp.send(null); + } + + +// function reload() { +// xmlhttp=new XMLHttpRequest(); +// xmlhttp.onreadystatechange = function() { +// if(xmlhttp.readyState == 4) { +// document.getElementById("content").innerHTML=xmlhttp.responseText; +// if(document.getElementById('logbox')) { +// if(saveScrollTop) { +// document.getElementById('logbox').scrollTop = saveScrollTop; +// } +// } +// +// document.getElementById("stop").style.background="#444"; +// reloadevery = setTimeout('reload()',$.($delay*1000).qq$); +// } +// }; +// if(document.getElementById('logbox')) { +// saveScrollTop = document.getElementById('logbox').scrollTop; +// if (saveScrollTop == 0) {saveScrollTop = 0.1;} +// } +// xmlhttp.open("GET","get.cgi?$.$ENV{'QUERY_STRING'}.qq$",true); +// xmlhttp.send(null); +// document.getElementById("stop").style.background="#111"; +// } \ No newline at end of file diff --git a/powersupplies/web/htdocs/styles.css b/powersupplies/web/htdocs/styles.css new file mode 100644 index 0000000..7d6a735 --- /dev/null +++ b/powersupplies/web/htdocs/styles.css @@ -0,0 +1,57 @@ +body { + background:#eee; +} + +.smallboxes { + border-collapse:collapse; + border:1px solid black; +} + + +#headline { +font-weight:normal; +font-size:90%; +} + + +.smallboxes input { + width:50px; + } + +.smallboxes .sep { + border-bottom:1px solid black; +} + +.smallboxes td:nth-child(even), .smallboxes th { + border-left:1px solid black; + } + +.smallboxes td { + padding:1px; +} + +td.state { + padding-left:10px; + text-align:center; + +} + + +#info { +font-size:70%; +text-align:right; +} + +.powerswitch .status { + min-width:20px; + width:20px; +} + +tfoot>tr:first-child { + border-top:1px solid black; +} + +.powerswitch td { + border-left:1px solid black; + text-align:center; +} \ No newline at end of file diff --git a/powersupplies/web/httpi b/powersupplies/web/httpi new file mode 100755 index 0000000..8f8623e --- /dev/null +++ b/powersupplies/web/httpi @@ -0,0 +1,537 @@ +#!/usr/bin/perl +use POSIX qw(SIGALRM SIGTERM sigaction); + +use lib "."; +use Digest::SHA::PurePerl qw(sha1_base64); + + +$VERSION = "1.7 (Demonic/Linux)"; + +# HTTPi Hypertext Tiny Truncated Process Implementation +# Copyright 1999-2010 Cameron Kaiser and Contributors # All rights reserved +# Please read LICENSE # Do not strip this copyright message. + +############################################################### +# WHITE HATS ONLY BELOW THIS POINT -- SEE DOCUMENTATION FIRST # +############################################################### + +%system_content_types = + ("html" => "text/html", + "htm" => "text/html", + "txt" => "text/plain", + "xml" => "text/xml", + "xsl" => "text/xml", + "xhtml" => "application/xhtml+xml", + "css" => "text/css", + "gif" => "image/gif", + "jpeg" => "image/jpeg", + "jpg" => "image/jpeg", + "bmp" => "image/bmp", + "png" => "image/png", + "tif" => "image/tiff", + "tiff" => "image/tiff", + "ico" => "image/x-icon", + "svg" => "image/svg+xml", + "svgz" => "image/svg+xml", + "wbmp" => "image/vnd.wap.wbmp", + "wbm" => "image/vnd.wap.wbmp", + "xbm" => "image/x-xbitmap", + "mp3" => "audio/x-mpeg", + "wma" => "audio/x-ms-wma", + "wav" => "audio/x-wav", + "au" => "audio/basic", + "aif" => "audio/x-aiff", + "aiff" => "audio/x-aiff", + "ogg" => "audio/x-ogg", + "oga" => "audio/x-ogg", + "mid" => "audio/midi", + "wma" => "audio/x-ms-wma", + "mpeg" => "video/mpeg", + "mpg" => "video/mpeg", + "aac" => "audio/aac", + "ogv" => "video/x-ogg", + "ogx" => "application/x-ogg", + "avi" => "video/x-msvideo", + "wmv" => "video/x-ms-wmv", + "asf" => "video/x-ms-asf", + "mov" => "video/quicktime", + "mp4" => "video/mp4", + "rv" => "video/vnd.m-realvideo", + "rm" => "application/vnd.m-realmedia", + "ra" => "audio/vnd.m-realaudio", + "ram" => "audio/vnd.m-realaudio", + "pdf" => "application/pdf", + "fdf" => "application/vnd.fdf", + "class" => "application/octet-stream", + "jar" => "application/octet-stream", + "js" => "application/x-javascript", + "lnk" => "application/x-hyperlink", + "prg" => "application/x-c64-prg-binary", + "d64" => "application/x-c64-disk-image", + "tar" => "application/x-tar", + "sit" => "application/x-stuffit", + "Z" => "application/x-compress", + "gz" => "application/x-gzip", + "dmg" => "application/octet-stream", + "img" => "application/octet-stream", + "lzh" => "application/octet-stream", + "lha" => "application/octet-stream", + "exe" => "application/octet-stream", + "com" => "application/octet-stream", + "zip" => "application/x-zip-compressed", + "hqx" => "application/x-binhex", + "swf" => "x-shockwave-flash", + "flv" => "video/x-flv", + + "bin" => "application/octet-stream"); + +# comment in to enable logs +#$logfile = "./access.log"; +$path = "./htdocs"; +$sockaddr = 'S n a4 x8'; + +$server_host = $ARGV[0]; +$server_port = $ARGV[1]; + +die("$0 [host] [port] required. got >$server_host< >$server_port<") unless ($server_host and $server_port); + +%content_types = + ("html" => "text/html", + "htm" => "text/html", + "shtml" => "text/html" + ); +%restrictions = ( + "/nw" => "^10\.##^Mozilla#MSIE", + "/status" => "####voyeur:daNrZR3TcSwD2", + "/" => "###(NPBot|WebZIP|HTTrack|eCatch|Offline Explorer|UdmSearch|WebCopier|internetseer|MSIECrawler|SuperBot|LinkWalker|Tutorial Crawler|WebReaper)", + ); + # See documentation for interpreting this string. + +$headers = <<"EOF"; +Server: TRB based on HTTPi/$VERSION +MIME-Version: 1.0 +EOF + + +%content_types = (%system_content_types, %content_types); +undef %system_content_types; + +#if ($pid = fork()) { exit; } +$0 = "dhttpi: binding port ..."; +$bindthis = pack($sockaddr, 2, $server_port, pack('C4', 0, 0, 0, 0)); +socket(S, 2, 1, 6); +setsockopt(S, 1, 2, 1); +bind(S, $bindthis) || die("$0: while binding port $server_port:\n\"$!\"\n"); +listen(S, 128); +$0 = "dhttpi: connected and waiting ANY:$server_port"; + +$statiosuptime = time(); + +sub sock_to_host { + return ($cache_hn, $cache_port, $cache_ip) + if (length($cache_ip)); + + return (undef, undef, undef) if (!$sock); + my($AFC, $cache_port, $thataddr, $zero) = unpack($sockaddr, $sock); + $cache_ip = join('.', unpack("C4", $thataddr)); + $cache_hn = + gethostbyaddr($thataddr, 2) || + $cache_ip; + return ($cache_hn, $cache_port, $cache_ip); +} + + +sub htsponse { + ($currentcode, $currentstring) = (@_); + return if (0+$httpver < 1); + my($what) = <<"EOF"; +HTTP/$httpver $currentcode $currentstring +${headers}Date: $rfcdate +EOF + $what =~ s/\n/\r\n/g; + print STDOUT $what; + &hthead("Connection: close") if (0+$httpver > 1); +} + +sub hthead { + my($header, $term) = (@_); + return if (0+$httpver < 1); + print STDOUT "$header\r\n" , ($term) ? "\r\n" : ""; +} + +sub htcontent { + my($what, $ctype, $mode) = (@_); + ($contentlength) = $mode || length($what); + &hthead("Content-Length: $contentlength"); + &hthead("Content-Type: $ctype", 1); + return if ($method eq 'HEAD' || $mode); + print STDOUT $what; +} + +sub log { + if ($logfile && open(J, ">>$logfile")) { + my $q = $address . (($variables) ? "?$variables" : ""); + $contentlength += 0; + $contentlength = 0 if ($method eq 'HEAD'); + my ($hostname, $port, $ip) = &sock_to_host(); + $hostname ||= "-"; + $httpuser ||= "-"; + print J <<"EOF"; +$hostname - $httpuser [$date] "$method $q HTTP/$httpver" $currentcode $contentlength "$httpref" "$httpua" +EOF + close(J); + } +} + + +sub bye { exit; } +sub byebye { kill(9,$secondary_pid) if ($secondary_pid); exit; } + +sub dead { + &htsponse(500, "Server Error"); + &hterror("Server Error", <<"EOF"); +The server cannot comply with your request for resource $::address. +Please attempt to notify the administrators. +

Useful(?) debugging information: +

+@_
+
+EOF + &log; exit; +} + +sub defaultsignals { + $SIG{'__DIE__'} = \&dead; + sigaction SIGALRM, new POSIX::SigAction \&bye + or die "sigalrm failed: $!\n"; + sigaction SIGTERM, new POSIX::SigAction \&byebye + or die "sigterm failed: $!\n"; +} +&defaultsignals; + +sub alarmsignals { + undef $SIG{'__DIE__'}; + sigaction SIGALRM, new POSIX::SigAction sub { die; } + or die "sigalrm failed: $!\n"; +} + +sub master { + $0 = "dhttpi: handling request"; +$sock = getpeername(STDIN); +$rfcdate = &rfctime(scalar gmtime, 1); +$date = scalar localtime; +($dow, $mon, $dt, $tm, $yr) = ($date =~ + m/(...) (...) (..) (..:..:..) (....)/); +$dt += 0; +$dt = substr("0$dt", length("0$dt") - 2, 2); +$date = "$dt/$mon/$yr:$tm +0000"; + +select(STDOUT); $|=1; $address = 0; +alarm 5; +while () { + if(/^([A-Z]+)\s+([^\s]+)\s+([^\s\r\l\n]*)/) { + $method = $1; + $address = $2; + $httpver = $3; + $httpref = ''; + $httpua = ''; + $httpver = ($httpver =~ m#HTTP/([0-9]\.[0-9]+)#) ? + ($1) : (0.9); + $address =~ s#^http://[^/]+/#/#; + $0 = $execstring = "dhttpi: $method $address $httpver"; + next unless ($httpver < 1); + } else { + s/[\r\l\n\s]+$//; + (/^Host:\s+(.+)/i) && ($httphost = substr($1, 0, 255)) + && ($httphost =~ s/:\d+$//); + (/^Referer:\s+(.+)/i) && ($httpref = substr($1, 0, 1024)); + (/^User-agent:\s+(.+)/i) && ($httpua = substr($1, 0, 1024)); + (/^Content-length:\s+(\d+)/i) && + ($ENV{'CONTENT_LENGTH'} = $httpcl = 0+$1); + (/^Content-type:\s+(.+)/i) && + ($ENV{'CONTENT_TYPE'} = $httpct = substr($1, 0, 255)); + (/^Expect:\s+/) && ($expect = 1); + (/^Cookie:\s+(.+)/i) && + ($ENV{'HTTP_COOKIE'} = substr($1, 0, 16384)); + (/^Authorization:\s+Basic (.+)/i) && + ($httprawu = substr($1, 0, 1024)); + (/^Range:\s+(.+)/i) && + ($ENV{'CONTENT_RANGE'} = substr($1, 0, 255)); + (/^If-Modified-Since:\s+(.+)/i) && + ($modsince = $ENV{'HTTP_IF_MODIFIED_SINCE'} = + substr($1, 0, 255)); + (/^Accept:\s+(.+)/i) && + ($ENV{'HTTP_ACCEPT'} = substr($1, 0, 255)); + (/^Accept-([a-zA-Z0-9]+):\s+(.+)/i) && + ($ENV{'HTTP_ACCEPT_'.uc(substr($1, 0, 16))} = + substr($2, 0, 255)); + (/^X-Requested-With:\s+(.+)/i) && + ($ENV{'HTTP_X_REQUESTED_WITH'} = substr($1, 0, 1024)); + + (/^Origin:\s+(.+)/i) && + ($ENV{'HTTP_ORIGIN'} = substr($1, 0, 1024)); + (/^Upgrade:\s+(.+)/i) && + ($ENV{'HTTP_UPGRADE'} = substr($1, 0, 1024)); + (/^Sec-WebSocket-Protocol:\s+(.+)/i) && + ($ENV{'WEBSOCKET_PROTOCOL'} = substr($1, 0, 1024)); + (/^Sec-WebSocket-Version:\s+(-?\d+)/i) && + ($ENV{'WEBSOCKET_VERSION'} = substr($1, 0, 8)); + (/^Sec-WebSocket-Extensions:\s+(-?\d+)/i) && + ($ENV{'WEBSOCKET_EXTENSIONS'} = substr($1, 0, 1024)); + (/^Sec-WebSocket-Key:\s+(\S+)/i) && + ($ENV{'WEBSOCKET_KEY'} = substr($1, 0, 1024)); + + next unless (/^$/); + } + if ($expect) { + &htsponse(417, "Expectation Failed"); + &hterror("Expectation Failed", + "The server does not support this method."); + &log; exit; + } + if (!length($address) || (0+$httpver > 1 && !$httphost)) { + &htsponse(400, "Bad Request"); + &hterror("Bad Request", + "The server cannot understand your request."); + &log; exit; + } + if ($method !~ /^(GET|HEAD|POST)$/) { + &htsponse(501, "Not Implemented"); + &hterror("Not Implemented", + "Only GET, HEAD and POST are supported."); + &log; exit; + } + + + if ($ENV{'HTTP_UPGRADE'} eq 'websocket') { + if ($method ne "GET" || !$ENV{'WEBSOCKET_KEY'}) { + &htsponse(400, "Bad request"); + &hterror("Bad request", + "Illegal websocket opening handshake"); + &log; exit; + } + + $ENV{'WEBSOCKET_ACCEPT'} = + sha1_base64($ENV{'WEBSOCKET_KEY'} . "258EAFA5-E914-47DA-95CA-C5AB0DC85B11") . "="; + + + } + + + + ($address, $variables) = split(/\?/, $address); + $address =~ s/%([0-9a-fA-F]{2})/pack("H2", $1)/eg; + $address=~ s#^/?#/#; + 1 while $address =~ s#/\.(/|$)#\1#; + 1 while $address =~ s#/[^/]*/\.\.(/|$)#\1#; + 1 while $address =~ s#^/\.\.(/|$)#\1#; + $fail = 0; + J: foreach(sort { length $a <=> length $b } + keys %restrictions) { + next if ($address !~ /^$_/); + ($allowip, $denyip, $allowua, $denyua, $auser) = + split(/#/, $restrictions{$_}); + if ($allowip || $denyip) { + ($hostname, $port, $ip) = &sock_to_host(); + ($allowip && $ip !~ /$allowip/) && ($fail = 1, + last J); + ($denyip && $ip =~ /$denyip/) && ($fail = 1, + last J); + } + ($allowua && $httpua !~ /$allowua/) && + ($fail = 2, last J); + ($denyua && $httpua =~ /$denyua/) && + ($fail = 2, last J); + } + if ($fail) { + &htsponse(403, "Forbidden"); + if ($fail == 1) { + &hterror("Forbidden (Client Disallowed)", <<"EOF"); +Your network address ($ip) is not allowed to access this resource. +EOF + &log; exit; + } else { + &hterror("Forbidden (Browser Disallowed)", <<"EOF"); +The browser you are using ($httpua) is not capable of or +is not allowed access to this resource. +EOF + &log; exit; + } + } + if ($auser) { + $httprawu =~ tr#A-Za-z0-9+/##cd; + $httprawu =~ tr#A-Za-z0-9+/# -_#; + $httprawu = unpack("u", pack("c", 32+0.75*length($httprawu)) + . $httprawu); + ($httpuser, $httppw) = split(/:/, $httprawu); + $fail = 1; + foreach $user (split(/,/, $auser)) { + ($user, $pw) = split(/:/, $user); + ($fail = 0, last) if ($user eq $httpuser && + crypt($httppw, substr($pw, 0, 2)) eq $pw); + } + if ($fail) { + $httpuser = ''; + &htsponse(401, "Authorization Required"); + &hthead("WWW-Authenticate: Basic realm=\"$address\""); + &hterror("Authorization Required", <<"EOF"); +You must provide a username and password to use this resource. Either you +entered this information incorrectly, or your browser does not know how to +present the credentials required. +EOF + &log; exit; + } + } + + alarm 0; + + + + + $raddress = "$path$address" + ; + 1 while ($raddress =~ s#//#/#); + &hterror301("http://$server_host:$server_port$address/") + if ($address !~ m#/$# && -d $raddress); + $raddress = (-r "${raddress}index.shtml") ? + "${raddress}index.shtml" : "${raddress}index.html" + if (-d $raddress); + IRED: ($hostname, $port, $ip) = &sock_to_host(); + if(!sysopen(S, $raddress, 0)) { &hterror404; } else { + if ((-x $raddress) + ) { + $currentcode = 100; &nsecmodel; + $ENV{'REQUEST_METHOD'} = $method; + $ENV{'SERVER_NAME'} = $server_host; + $ENV{'SERVER_PROTOCOL'} = "HTTP/$httpver"; + $ENV{'SERVER_SOFTWARE'} = "HTTPi/$VERSION"; + $ENV{'SERVER_PORT'} = "$server_port"; + $ENV{'SERVER_URL'} = "http://$server_host:$server_port/"; + $ENV{'SCRIPT_FILENAME'} = $raddress; + $ENV{'SCRIPT_NAME'} = $address; + $ENV{'REMOTE_HOST'} = $hostname; + $ENV{'REMOTE_ADDR'} = $ip; + $ENV{'REMOTE_PORT'} = $port; + $ENV{'QUERY_STRING'} = $variables; + $ENV{'HTTP_USER_AGENT'} = $httpua; + $ENV{'HTTP_REFERER'} = $httpref; + undef $pid; + if ($pid = fork()) { kill 15, $$; exit; } + elsif (!defined($pid)) { + die + "temporary(?) fork error, please retry request: $!\n"; + } else { + require $raddress; + exit; + } + } + ($x,$x,$x,$x,$x,$x,$x,$length,$x,$mtime) = stat(S); + $ctype = 0; + foreach(keys %content_types) { + if ($raddress =~ /\.$_$/i) { + $ctype = $content_types{$_}; + } + } + $mtime = &rfctime($mtime); +SERVEIT: + if ($mtime eq $modsince) { + &htsponse(304, "Not Modified"); + &hthead("Last-Modified: $mtime", 1); + &log; exit; + } + $ctype ||= 'text/plain'; + if ($pid = fork()) { kill 15, $$; exit; } + $contentlength ||= $length; + &htsponse(200, "OK"); + &hthead("Last-Modified: $mtime"); + &htcontent("", $ctype, $length); + &nsecmodel; + $bytecount = 0; + unless ($method eq 'HEAD') { + while(!eof(S)) { + read(S, $q, 32768); + print STDOUT $q; + $bytecount += 32768; + $0 = $execstring . + " ($bytecount bytes sent)"; + } + } + alarm 0; + } + exit; +} + +exit; +} + + +sub nsecmodel { + &log; + ($x,$x,$x,$x,$uid,$gid) = stat(S); + (!$uid || !$gid || $uid < 2 ) && + die "resource is root-owned, secured or not stat-able\n"; + if (!$<) { + ($) = "$gid $gid") || die "can't set egid to $gid"; + ($> = $uid) || die "can't set euid to $uid"; + ($( = "$gid $gid") || die "can't set rgid to $gid"; + ($< = $uid) || die "can't set ruid to $uid"; + } +} + +sub rfctime { + my $mtime = shift; + $mtime = (scalar gmtime $mtime) if (!(shift)); + my ($dow, $mon, $dt, $tm, $yr) = + ($mtime =~ m/(...) (...) (..) (..:..:..) (....)/); + $dt += 0; $yr += 0; + return "$dow, $dt $mon $yr $tm GMT"; +} + +sub hterror { + my($errstr, @expl) = (@_); + &htcontent(<<"EOF", "text/html"); + + +

$errstr

+@expl +
+
httpi/$VERSION +by Cameron Kaiser
+ + +EOF + } + +sub hterror404 { + &htsponse(404, "Not Found"); + &hterror("Not Found", + "The resource $address was not found on this system."); + &log; exit; +} + +sub hterror301 { + &htsponse(301, "Moved Permanently"); + &hthead("Location: @_"); + &hterror("Resource Moved Permanently", + "This resource has moved here."); + &log; exit; +} + + +$0 = "dhttpi: on ANY:$server_port, ready!"; +$master_pid = $$; +for (;;) { + if ($secondary_pid = fork()) { + waitpid($secondary_pid, 0); + $0 = "dhttpi: on ANY:$server_port, last request " . + scalar localtime; + } else { + $0 = "dhttpi (child of $master_pid): waiting for connect"; + $addr=accept(NS,S); + open(STDIN, "<&NS"); + open(STDOUT, ">&NS"); + &defaultsignals; + &master; + exit; + } +}