#!/usr/bin/perl
use strict;
use warnings;
 
use HTTP::Engine;
 
my $engine = HTTP::Engine->new(
  interface => {
    module => 'ServerSimple',
    args   => {
      host => 'localhost',
      port => '8080',
    },
    request_handler => \&handle_request,
  },
);
 
use HTTP::Engine::Response;
 
sub fisher_yates_shuffle {
  my $deck = shift;    # $deck is a reference to an array
  return unless @$deck;    # must not be empty!
 
  my $i = @$deck;
  while ( --$i ) {
    my $j = int rand( $i + 1 );
    @$deck[ $i, $j ] = @$deck[ $j, $i ];
  }
}
 
sub randcookie {
  my (@chars) = map { chr($_) } map { ord('A') .. ord('z') } 1 .. 10;
  fisher_yates_shuffle( \@chars );
  return join '', @chars[ 0 .. 10 ];
}
 
sub handle_request {
  my $req  = shift;
  my $resp = HTTP::Engine::Response->new();
 
  use YAML::XS qw( Dump );
 
  my $ctext = Dump({
      cookies => $req->cookies ,
      headers => $req->headers,
      request_uri => $req->request_uri,
  }  );
 
  $resp->status(200);
  $resp->headers->header( 'Content-Type' => 'text/plain' );
  $resp->body( $ctext );
 
  if( $req->request_uri =~ qr{/normal$} ){
    normal_cookies( $resp );
    return $resp;
  }
  if( $req->request_uri =~ qr{/normal2$} ){
    normal_cookies2( $resp );
    return $resp;
  }
 
  if( $req->request_uri =~ qr{/weird$} ){
    weird_cookies( $resp );
    return $resp;
  }
  if( $req->request_uri =~ qr{/weird2$} ){
    weird_cookies2( $resp );
    return $resp;
  }
  if( $req->request_uri =~ qr{/weird3$} ){
    weird_cookies3( $resp );
    return $resp;
  }
  if( $req->request_uri =~ qr{/weird4$} ){
    weird_cookies4( $resp );
    return $resp;
  }
 
 
  $resp->headers->header( 'Content-Type' => "text/html" );
  $resp->body(<<'EOF');
  <ul>
  <li><a href="/weird">Weird Cookies ( 2 cookies, 1 path, 1 string ) </a>
  <li><a href="/weird2">Weird Cookies2 ( 2 cookies, 1 path, array ) </a>
  <li><a href="/weird3">Weird Cookies3 ( 2 cookies, 2 paths, 1 string ) </a>
  <li><a href="/weird4">Weird Cookies4 ( 2 cookies, 2 paths, array ) </a>
 
  <li><a href="/normal">Normal Cookies ( 1 value, 1 path ) </a>
  <li><a href="/normal2">Normal Cookies2 ( 1 path, valuearray )( WARNING: Kills Server )</a>
  </ul>
EOF
 
  return $resp;
}
 
# Firefox only returns the most recently set value of foo.
 
sub normal_cookies {
  my $resp = shift;
  $resp->cookies->{foo} = { value => randcookie() };
}
 
# Firefox only returns the most recently set value of foo.
 
sub normal_cookies2 {
  my $resp = shift;
  # this is illegal.
  $resp->cookies->{foo} = [
    { value => 'A' . randcookie() },
    { value => 'B' . randcookie() },
  ];
}
 
#
#
# Note: We sent 2 cookies with identical keys,
# but firefox only sees the first, and returns only the first.
#
sub weird_cookies {
  my $resp = shift;
  $resp->headers->header('Set-Cookie' => 'foo=A' . randcookie(). '; path=/; foo=B' . randcookie() . '; path=/;' );
}
 
#
# This also sends 2 cookies, but puts a \n in the response, ie:
# >>
# Connection: close
# Content-Length: 586
# Content-Type: text/plain
# Set-Cookie: foo=AqZI_GmTOBlV; path=/;
# foo=BwMD^frWvQoW; path=/;
# Status: 200
# >>
 
# Firefox in this case only sees the last cookie.
#
sub weird_cookies2 {
  my $resp = shift;
  $resp->headers->header('Set-Cookie' => [
    'foo=A' . randcookie(). '; path=/;',
    'foo=B' . randcookie() . '; path=/;'
  ]);
}
 
sub weird_cookies3 {
  my $resp = shift;
  $resp->headers->header('Set-Cookie' => 'foo=A' . randcookie(). '; path=/; foo=B' . randcookie() . '; path=/wierd3;' );
}
 
sub weird_cookies4 {
  my $resp = shift;
  $resp->headers->header('Set-Cookie' => [
    'foo=A' . randcookie(). '; path=/;',
    'foo=B' . randcookie() . '; path=/weird4;'
  ]);
}
 
$engine->run();