Web interface for MasterServer-Perl

5 files changed, 322 insertions, 0 deletions

diff --git a/lib/MasterWebInterface/Util/BrowseHTML.pm b/lib/MasterWebInterface/Util/BrowseHTML.pm
new file mode 100755
index 0000000..32d773e
--- /dev/null
+++ b/lib/MasterWebInterface/Util/BrowseHTML.pm
@@ -0,0 +1,126 @@
+package MasterWebInterface::Util::BrowseHTML;
+use strict;
+use warnings;
+use TUWF ':html', 'xml_escape';
+use Exporter 'import';
+use POSIX 'ceil';
+our @EXPORT = qw| htmlBrowse htmlBrowseNavigate |;
+
+# generates a browse box, arguments:
+#  items    => arrayref with the list items
+#  options  => hashref containing at least the keys s (sort key), o (order) and p (page)
+#  nextpage => whether there's a next page or not
+#  sorturl  => base URL to append the sort options to (if there are any sortable columns)
+#  pageurl  => base URL to append the page option to
+#  class    => classname of the mainbox
+#  header   =>
+#   can be either an arrayref or subroutine reference,
+#   in the case of a subroutine, it will be called when the header should be written,
+#   in the case of an arrayref, the array should contain the header items. Each item
+#   can again be either an arrayref or subroutine ref. The arrayref would consist of
+#   two elements: the name of the header, and the name of the sorting column if it can
+#   be sorted
+#  row      => subroutine ref, which is called for each item in $list, arguments will be
+#   $self, $item_number (starting from 0), $item_value
+#  footer   => subroutine ref, called after all rows have been processed
+# Mostly written by Yorhel --> https://g.blicky.net/vndb.git/tree/COPYING
+sub htmlBrowse {
+  my($self, %opt) = @_;
+
+  $opt{sorturl} .= $opt{sorturl} =~ /\?/ ? ';' : '?' if $opt{sorturl};
+
+  # top navigation
+  $self->htmlBrowseNavigate($opt{pageurl}, $opt{options}{p}, $opt{nextpage}, 't') if $opt{pageurl};
+
+  div class => 'mainbox browse'.($opt{class} ? ' '.$opt{class} : '');
+   table class => 'stripe';
+
+   # header
+    thead;
+     Tr;
+      if(ref $opt{header} eq 'CODE') {
+        $opt{header}->($self);
+      } else {
+        for(0..$#{$opt{header}}) {
+          if(ref $opt{header}[$_] eq 'CODE') {
+            $opt{header}[$_]->($self, $_+1);
+          } elsif ($opt{simple}) {
+            td class => $opt{header}[$_][3]||'tc'.($_+1), $opt{header}[$_][2] ? (colspan => $opt{header}[$_][2]) : ();
+            if($opt{header}[$_][1]) {
+              lit qq|<a href="$opt{sorturl}o=d;s=$opt{header}[$_][1]">$opt{header}[$_][0]</a>|;} 
+            else {
+              txt $opt{header}[$_][0];}
+            end;          
+          } else {
+            td class => $opt{header}[$_][3]||'tc'.($_+1), $opt{header}[$_][2] ? (colspan => $opt{header}[$_][2]) : ();
+             lit $opt{header}[$_][0];
+             if($opt{header}[$_][1]) {
+               lit ' ';
+               $opt{options}{s} eq $opt{header}[$_][1] && $opt{options}{o} eq 'a' ? lit "\x{25B4}" : a href => "$opt{sorturl}o=a;s=$opt{header}[$_][1]", "\x{25B4}";
+               $opt{options}{s} eq $opt{header}[$_][1] && $opt{options}{o} eq 'd' ? lit "\x{25BE}" : a href => "$opt{sorturl}o=d;s=$opt{header}[$_][1]", "\x{25BE}";
+             }
+            end;
+          }
+        }
+      }
+     end;
+    end 'thead';
+
+   # footer
+    if($opt{footer}) {
+      tfoot;
+       $opt{footer}->($self);
+      end;
+    }
+
+   # rows
+    $opt{row}->($self, $_+1, $opt{items}[$_])
+      for 0..$#{$opt{items}};
+
+   end 'table';
+  end 'div';
+
+  # bottom navigation
+  $self->htmlBrowseNavigate($opt{pageurl}, $opt{options}{p}, $opt{nextpage}, 'b') if $opt{pageurl};
+}
+
+
+# creates next/previous buttons (tabs), if needed
+# Arguments: page url, current page (1..n), nextpage (0/1 or [$total, $perpage]), alignment (t/b), noappend (0/1)
+# Mostly written by Yorhel --> https://g.blicky.net/vndb.git/tree/COPYING
+sub htmlBrowseNavigate {
+  my($self, $url, $p, $np, $al, $na) = @_;
+  my($cnt, $pp) = ref($np) ? @$np : ($p+$np, 1);
+  return if $p == 1 && $cnt <= $pp;
+
+  $url .= $url =~ /\?/ ? ';p=' : '?p=' unless $na;
+
+  my $tab = sub {
+    my($left, $page, $label) = @_;
+    li $left ? (class => 'left') : ();
+     a href => $url.$page; lit $label; end;
+    end;
+  };
+  my $ell = sub {
+    use utf8;
+    li class => 'ellipsis'.(shift() ? ' left' : '');
+     b '⋯';
+    end;
+  };
+  my $nc = 5; # max. number of buttons on each side
+
+  ul class => 'maintabs browsetabs ' . ($al eq 't' ? 'notfirst' : 'bottom');
+   $p > 2     and ref $np and $tab->(1, 1, '&laquo; first');
+   $p > $nc+1 and ref $np and $ell->(1);
+   $p > $_    and ref $np and $tab->(1, $p-$_, $p-$_) for (reverse 2..($nc>$p-2?$p-2:$nc-1));
+   $p > 1                 and $tab->(1, $p-1, '&lsaquo; previous');
+
+   my $l = ceil($cnt/$pp)-$p+1;
+   $l > 2     and $tab->(0, $l+$p-1, ('last').' &raquo;');
+   $l > $nc+1 and $ell->(0);
+   $l > $_    and $tab->(0, $p+$_, $p+$_) for (reverse 2..($nc>$l-2?$l-2:$nc-1));
+   $l > 1     and $tab->(0, $p+1, ('next').' &rsaquo;');
+  end 'ul';
+}
+
+1;
diff --git a/lib/MasterWebInterface/Util/CommonHTML.pm b/lib/MasterWebInterface/Util/CommonHTML.pm
new file mode 100755
index 0000000..5390740
--- /dev/null
+++ b/lib/MasterWebInterface/Util/CommonHTML.pm
@@ -0,0 +1,26 @@
+package MasterWebInterface::Util::CommonHTML;
+use strict;
+use warnings;
+use TUWF ':html';
+use Exporter 'import';
+our @EXPORT = qw| htmlSearchBox |;
+
+################################################################################
+# Search box with first letters
+# for games, servers and possibly later on players
+################################################################################
+sub htmlSearchBox {
+  my($self, $sel, $v) = @_;
+
+  fieldset class => 'search';
+   p id => 'searchtabs';
+    a href => '/g/all', $sel eq 'g' ? (class => 'sel') : (),  'Games';
+    a href => '/s/all', $sel eq 's' ? (class => 'sel') : (),  'Servers';
+    #a href => '/p/all', $sel eq 'p' ? (class => 'sel') : (),  'Players';
+   end;
+   input type => 'text', name => 'q', id => 'q', class => 'text', value => $v;
+   input type => 'submit', class => 'submit', value =>  'search';
+  end 'fieldset';
+}
+
+1;
diff --git a/lib/MasterWebInterface/Util/Figures.pm b/lib/MasterWebInterface/Util/Figures.pm
new file mode 100755
index 0000000..a3f3e5f
--- /dev/null
+++ b/lib/MasterWebInterface/Util/Figures.pm
@@ -0,0 +1,38 @@
+package MasterWebInterface::Util::Figures;
+use strict;
+use warnings;
+use TUWF ':html';
+use Exporter 'import';
+use Image::Size;
+our @EXPORT = qw| figure figurelink |;
+
+################################################################################
+# Load image in Yorhel's IV.
+################################################################################
+sub figure {
+  my ($self, $d, $f, $s) = @_;
+  my $extra_css = (defined($s)) ? "style=\"$s\"" : "";
+  my ($w, $h) = imgsize("$self->{img_path}/$d/$f");
+    # make a link and show a thumbnail if exists, else photo itself
+    if (-e "$self->{img_path}/t/$f") { 
+      lit "<a rel=\"iv:$w"."x"."$h\" href=\"/img/$d/$f\"><img $extra_css src=\"/img/t/$f\" alt=\"$f\"/></a> "
+    }
+    else{
+      lit "<a rel=\"iv:$w"."x"."$h\" href=\"/img/$d/$f\"><img $extra_css src=\"/img/$d/$f\" alt=\"$f\"/></a> "}
+}
+
+################################################################################
+# Have a picture $f link to destination $dest -- wrapper function
+################################################################################
+sub figurelink {
+  my ($self, $d, $f, $dest) = @_;
+    # make a link and show a thumbnail if exists, else photo itself
+    if (-e "$self->{img_path}/t/$f") { 
+      lit "<a href=\"$dest\"><img src=\"/img/t/$f\" alt=\"$f\"/></a> "
+    }
+    else{
+      lit "<a href=\"$dest\"><img src=\"/img/$d/$f\" alt=\"$f\"/></a> "}
+}
+
+
+1;
diff --git a/lib/MasterWebInterface/Util/Layout.pm b/lib/MasterWebInterface/Util/Layout.pm
new file mode 100755
index 0000000..4f62d5e
--- /dev/null
+++ b/lib/MasterWebInterface/Util/Layout.pm
@@ -0,0 +1,60 @@
+package MasterWebInterface::Util::Layout;
+use strict;
+use warnings;
+use TUWF ':html';
+use Exporter 'import';
+our @EXPORT = qw| htmlHeader htmlFooter |;
+
+################################################################################
+# htmlHeader
+# options: title, noindex
+################################################################################
+sub htmlHeader {
+  my($self, %o) = @_;
+
+  html lang => "en";
+    head;
+      title "$o{title} :: $self->{site_title}";
+      Link rel => 'shortcut icon', href => "$self->{url}/favicon.ico", type => 'image/x-icon';
+      Link rel => 'stylesheet', href => "$self->{url}/style/$self->{style}/style.css", type => "text/css", media => "all";
+      meta name => "google-site-verification", content => "tkhIW87EwqNKSGEumMbK-O3vqhwaANWbNxkdLBDGZvI";end;
+      meta name => 'robots', content => 'noindex,nofollow,nosnippet,noodp,noarchive,noimageindex';end; #FIXME set proper robots params
+      script type => 'text/javascript', src => "$self->{url}/interface-scripts.js", '';
+    end; # head
+    
+    body;
+      div class => 'nav';
+        ul;
+          li; a href => "/",           "home";    end;
+          li; a href => "/g/all",      "games";   end;
+          li; a href => "/s/all",      "servers"; end;
+        end;
+      end;
+    
+      div id => "body";
+        # start the page content with a header logo box
+        div class => "titlebox";
+        end;
+}
+
+################################################################################
+# htmlFooter
+# options: last edited (not shown)
+# General html layout header (bottom)
+################################################################################
+sub htmlFooter {
+  my $self = shift;
+      br style => "clear:both";
+      
+        div id => 'footer';
+          txt "$self->{site_title} | Powered by ";
+          a href => "http://333networks.com", "333networks";
+          txt " & ";
+          a href => "http://dev.yorhel.nl/tuwf", "TUWF";
+        end;
+      end 'div'; # body
+    end 'body';
+  end 'html';
+}
+
+1;
diff --git a/lib/MasterWebInterface/Util/Misc.pm b/lib/MasterWebInterface/Util/Misc.pm
new file mode 100755
index 0000000..0be7aae
--- /dev/null
+++ b/lib/MasterWebInterface/Util/Misc.pm
@@ -0,0 +1,72 @@
+package MasterWebInterface::Util::Misc;
+use strict;
+use warnings;
+use TUWF ':html';
+use POSIX 'strftime';
+use Exporter 'import';
+use Encode 'encode_utf8';
+use Geography::Countries;
+use Unicode::Normalize 'NFKD';
+use Socket 'inet_pton', 'inet_ntop', 'AF_INET', 'AF_INET6';
+our @EXPORT = qw| date_new timeformat countryflag valid_address |;
+
+################################################################################
+# time formatting for when a server was added
+################################################################################
+sub date_new {
+  my ($s, $d) = @_;
+  #return (strftime "%a %H:%M:%S", gmtime $d);
+  return (strftime "%a %H:%M", gmtime $d); # no seconds
+}
+
+################################################################################
+# time formatting for when a server was added / last updated
+################################################################################
+sub timeformat {
+  my ($self, $time) = @_;
+  
+  # parse seconds with gmtime
+  my @t = gmtime($time);
+  my $r = "";
+
+  # parse into d HH:mm:SS format
+  if ($t[7]){$r .= $t[7]."d "}
+  if ($t[2]){$r .= ($t[2] > 9) ? $t[2].":" : "0".$t[2].":" }
+  if ($t[1]){$r .= ($t[1] > 9) ? $t[1].":" : "0".$t[1].":" } else {$r .= "00:";}
+  if ($t[0]){$r .= ($t[0] > 9) ? $t[0] : "0".$t[0]         } else {$r .= "00";}
+  
+  return $r;
+}
+
+################################################################################
+# returns flag, country name
+################################################################################
+sub countryflag {
+  my ($self, $c) = @_;
+  my $flag = ($c ? lc $c : 'earth');
+  my $coun = $c ? ( $c eq 'EU' ? 'Europe' : country $c ) : 'Earth' ;
+  return $flag, $coun;  
+}
+
+################################################################################
+# Verify whether a given domain name or IP address and port are valid.
+# returns the valid ip-address + port, or 0 when not.
+################################################################################
+sub valid_address {
+  my ($self, $a, $p) = @_;
+
+  # check if ip and port are in valid range
+  my $val_addr = ($a =~ '^(?:(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)\.){3}(?:25[0-5]|2[0-4]\d|1\d\d|[1-9]?\d)$') if $a;
+  my $val_port = ($p =~  m/^\d+$/ && 0 < $p && $p <= 65535) if $p;
+  
+  # exclude local addresses
+  if ($a =~ m/192.168.(\d).(\d)/ || $a =~ m/127.0.(\d).(\d)/ || $a =~ m/10.0.(\d).(\d)/) { $val_addr = 0; }
+  
+  # return valid params
+  return (
+    $val_addr ? $a : 0,
+    $val_port ? $p : 0
+  );
+}
+
+1;