lib/App/Web/Oof.pm

   1 package App::Web::Oof;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6 use utf8;
   7 use parent qw/Plack::Component/;
   8
   9 our $VERSION = '0.000_004';
  10
  11 use DBIx::Simple;
  12 use File::Slurp;
  13 use HTML::TreeBuilder;
  14 use HTML::Element::Library;
  15 use JSON::MaybeXS qw/encode_json decode_json/;
  16 use Plack::Builder;
  17 use Plack::Request;
  18 use Try::Tiny;
  19
  20 sub HTML::Element::iter3 {
  21         my ($self, $data, $code) = @_;
  22         my $orig = $self;
  23         my $prev = $orig;
  24         for my $el (@$data) {
  25                 my $current = $orig->clone;
  26                 $code->($el, $current);
  27                 $prev->postinsert($current);
  28                 $prev = $current;
  29         }
  30         $orig->detach;
  31 }
  32
  33 sub HTML::Element::fid    { shift->look_down(id    => shift) }
  34 sub HTML::Element::fclass { shift->look_down(class => qr/\b$_[0]\b/) }
  35
  36 ##################################################
  37
  38 my %db;
  39 my ($form, $continue, $order, $details, $pay);
  40
  41 {
  42         sub parse_html {
  43                 my $builder = HTML::TreeBuilder->new;
  44                 $builder->ignore_unknown(0);
  45                 $builder->parse_file("tmpl/$_[0].html");
  46                 $builder
  47         }
  48
  49         $form     = parse_html 'form';
  50         $continue = parse_html 'continue';
  51         $order    = parse_html 'order';
  52         $details  = parse_html 'details';
  53         $pay      = parse_html 'pay';
  54 }
  55
  56 sub stringify_money { sprintf "£%.2f", $_[0] / 100 }
  57
  58 sub make_slug {
  59         my $slug = $_[0];
  60         $slug =~ y/ /-/;
  61         $slug =~ y/a-zA-Z0-9-//cd;
  62         $slug
  63 }
  64
  65 our %highlight;
  66 sub form_table_row {
  67         my ($data, $tr) = @_;
  68         $tr->attr(class => 'highlight') if $highlight{$data->{product}};
  69         $tr->fclass($_)->replace_content($data->{$_}) for qw/title subtitle stock/;
  70         $tr->fclass('price')->replace_content(stringify_money $data->{price});
  71         $tr->fclass('freepost')->detach unless $data->{freepost};
  72         $tr->fclass('title')->attr('data-product', $data->{product});
  73         $tr->fclass('title')->attr('href', '/details/'.$data->{product}.'/'.make_slug $data->{title});
  74 #       $tr->fclass('title')->attr('data-summary', $data->{summary});
  75         $tr->look_down(_tag => 'input')->attr(max => $data->{stock});
  76         $tr->look_down(_tag => 'input')->attr(name => 'quant'.$data->{product});
  77 }
  78
  79 sub form_app {
  80         my ($env) = @_;
  81         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
  82         my $req = Plack::Request->new($env);
  83
  84         local %highlight = map { $_ => 1 } $req->param('highlight');
  85         my $data = $db{$$}->select(products => '*', {}, 'product')->hashes;
  86         my $tree = $form->clone;
  87         $tree->find('tbody')->find('tr')->iter3($data, \&form_table_row);
  88
  89         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
  90 }
  91
  92 sub continue_table_row {
  93         my ($data, $tr) = @_;
  94         $tr->fclass($_)->replace_content($data->{$_}) for qw/title subtitle quantity/;
  95         $tr->fclass('freepost')->detach unless $data->{freepost};
  96         $tr->fclass('price')->replace_content(stringify_money $data->{subtotal});
  97         $tr->fclass('title')->attr('data-product', $data->{product});
  98 }
  99
 100 sub continue_app {
 101         my ($env) = @_;
 102         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 103         my $tree = $continue->clone;
 104         my $req = Plack::Request->new($env);
 105         my $params = $req->body_parameters;
 106
 107         my ($quant, $quant_freepost, $total, @data, @notes) = (0) x 3;
 108         for (sort keys %$params) {
 109                 next unless /^quant/;
 110                 next unless $params->{$_};
 111                 my $data = $db{$$}->select(products => '*', {product => substr $_, 5})->hash;
 112                 $data->{quantity} = $params->{$_};
 113                 if ($data->{stock} == 0) {
 114                         push @notes, 'Item is out of stock and was removed from order: '.$data->{title};
 115                         next
 116                 }
 117                 if ($data->{quantity} > $data->{stock}) {
 118                         $data->{quantity} = $data->{stock};
 119                         push @notes, 'Not enough units of "'.$data->{title}.'" available. Quantity reduced to '.$data->{quantity}
 120                 }
 121                 $data->{subtotal} = $data->{price} * $data->{quantity};
 122                 $quant += $data->{quantity};
 123                 $quant_freepost += $data->{quantity} if $data->{freepost};
 124                 $total += $data->{subtotal};
 125                 push @data, $data
 126         }
 127
 128         return [500, ['Content-type' => 'text/plain'], ['Error: no items in order.']] unless $quant;
 129
 130         $tree->fid('subtotal')->replace_content(stringify_money $total);
 131         my $dvalue;
 132         if ($params->{discount}) {
 133                 my $discount = $db{$$}->select(discounts => '*', {discount => $params->{discount}})->hash;
 134                 if (!defined $discount) {
 135                         push @notes, 'Discount code incorrect. No discount applied.'
 136                 } elsif ($db{$$}->select(orders => 'COUNT(*)', {discount => $params->{discount}})->list) {
 137                         push @notes, 'Discount code already used once. No discount applied.'
 138                 } else {
 139                         $dvalue = int (0.5 + $discount->{fraction} * $total) if $discount->{fraction};
 140                         $dvalue = $discount->{flat}                          if $discount->{flat};
 141                         $tree->fid('discount')->replace_content('-'.stringify_money $dvalue);
 142                         $total -= $dvalue;
 143                         $tree->look_down(name => 'discount')->attr(value => $params->{discount});
 144                         push @notes, 'Discount applied.'
 145                 }
 146         }
 147         $tree->look_down(name => 'discount')->detach unless $dvalue;
 148         $tree->fid('discount_tr')->detach unless $dvalue;
 149         my $postage = 220 + 50 * ($quant - $quant_freepost);
 150         $postage = 0 if $quant == $quant_freepost;
 151         $tree->fid('postage')->replace_content(stringify_money $postage);
 152         $total += $postage;
 153         $tree->fid('total')->replace_content(stringify_money $total);
 154
 155         $tree->fid('order')->find('tbody')->find('tr')->iter3(\@data, \&continue_table_row);
 156         $tree->iter($tree->fid('notes')->find('li') => @notes);
 157
 158         $tree->look_down(name => 'products')->attr(value => encode_json \@data);
 159         $tree->look_down(name => 'total')->attr(value => $total);
 160
 161         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 162 }
 163
 164 sub order_app {
 165         my ($env) = @_;
 166         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 167         my $tree = $order->clone;
 168         my $req = Plack::Request->new($env);
 169         my ($id) = $env->{PATH_INFO} =~ m,^/([0-9A-F]+),;
 170         if ($id) {
 171                 my $total = $db{$$}->select(orders => 'total', {id => $id})->list or
 172                   return [500, ['Content-type', 'text/plain'], ['Order not found']];
 173                 $tree->fid('orderid')->replace_content($id);
 174                 $tree->look_down(name => 'order')->attr(value => $id);
 175                 $tree->fid('total')->replace_content(stringify_money $total);
 176                 $tree->find('script')->attr('data-amount', $total);
 177                 return [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 178         } else {
 179                 my %parms = %{$req->body_parameters};
 180                 my $id = sprintf "%X%04X", time, $$;
 181                 my $err;
 182                 try {
 183                         $db{$$}->begin_work;
 184                         my $products = decode_json $req->body_parameters->{products};
 185                         for my $prod (@$products) {
 186                                 my $stock = $db{$$}->select(products => 'stock', {product => $prod->{product}})->list;
 187                                 die "Not enough of " .$prod->{title}."\n" if $prod->{quantity} > $stock;
 188                                 $db{$$}->update(products => {stock => $stock - $prod->{quantity}}, {product => $prod->{product}});
 189                         }
 190                         $db{$$}->insert(orders => {id => $id, %parms});
 191                         $db{$$}->commit;
 192                 } catch {
 193                         $db{$$}->rollback;
 194                         $err = [500, ['Content-type', 'text/plain'], ["Error: $_"]]
 195                 };
 196                 return $err if $err;
 197                 return [303, [Location => "/order/$id"], []]
 198         }
 199 }
 200
 201 sub cancel {
 202         my ($order) = @_;
 203         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 204         $order = $db{$$}->select(orders => '*', {id => $order})->hash;
 205         my $products = decode_json $order->{products};
 206         $db{$$}->begin_work;
 207         try {
 208                 for my $prod (@$products) {
 209                         my $stock = $db{$$}->select(products => 'stock', {product => $prod->{product}})->list;
 210                         $db{$$}->update(products => {stock => $stock + $prod->{quantity}}, {product => $prod->{product}});
 211                 }
 212                 $db{$$}->delete(orders => {id => $order->{id}});
 213                 $db{$$}->commit;
 214         } catch {
 215                 $db{$$}->rollback;
 216                 die $_
 217         }
 218 }
 219
 220 sub details_list_element {
 221         my ($data, $li) = @_;
 222         $li->find('a')->attr(href => "/$data");
 223         my $thumb = $data =~ s/fullpics/thumbs/r;
 224         $thumb = $data unless -f $thumb;
 225         $li->find('img')->attr(src => "/$thumb");
 226 }
 227
 228 sub details_app {
 229         my ($env) = @_;
 230         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 231         my $tree = $details->clone;
 232         my ($id) = $env->{PATH_INFO} =~ m,^/(\d+),;
 233         my ($title, $summary) = $db{$$}->select(products => [qw/title summary/], {product => $id})->list;
 234         my @pics = <static/fullpics/$id-*>;
 235         my $slug = make_slug $title;
 236         $tree->find('title')->replace_content("Pictures of $title | ledparts4you");
 237         $tree->find('h2')->replace_content($title);
 238         $tree->fid('summary')->replace_content($summary);
 239         $tree->look_down(rel => 'canonical')->attr(href => "/details/$id/$slug");
 240         $tree->fid('pictures')->find('li')->iter3(\@pics, \&details_list_element);
 241
 242         for my $ahref ($tree->find('a')) {
 243                 $ahref->attr(href => "/form?highlight=$id") if $ahref->attr('href') eq '/';
 244         }
 245
 246         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 247 }
 248
 249 sub pay_app {
 250         my ($env) = @_;
 251         my $req = Plack::Request->new($env);
 252         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 253         my $order = $req->body_parameters->{order};
 254         my $token = $req->body_parameters->{stripeToken};
 255         return [500, ['Content-type' => 'text/html; charset=utf-8'], ['No token received, payment did not succeed.']] unless $token;
 256         $db{$$}->update(orders => {stripe_token => $token}, {id => $order});
 257         [200, ['Content-type' => 'text/html; charset=utf-8'], [$pay->as_HTML]];
 258 }
 259
 260 sub app {
 261         my $footer = read_file 'tmpl/footer.html';
 262         builder {
 263                 enable sub {
 264                         my $app = shift;
 265                         sub {
 266                                 my $res = $app->(@_);
 267                                 $res->[2][0] =~ s,</body>,$footer</body>, if $res->[0] == 200;
 268                                 $res;
 269                         }
 270                 };
 271                 mount '/' => sub { [301, [Location => '/form'], []] };
 272                 mount '/form'     => \&form_app;
 273                 mount '/continue' => \&continue_app;
 274                 mount '/order'    => \&order_app;
 275                 mount '/details'  => \&details_app;
 276                 mount '/pay'      => \&pay_app;
 277         }
 278 }
 279
 280 1;
 281 __END__
 282
 283 =head1 NAME
 284
 285 App::Web::Oof - Oversimplified order form / ecommerce website
 286
 287 =head1 SYNOPSIS
 288
 289   use App::Web::Oof;
 290
 291 =head1 DESCRIPTION
 292
 293 Oof (Oversimplified order form) is a very simple ecommerce website.
 294 It is the code behind L<https://ledparts4you.uk.to>.
 295
 296 This version is reasonably functional, yet not very reusable, hence
 297 the version number.
 298
 299 =head1 AUTHOR
 300
 301 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 302
 303 =head1 COPYRIGHT AND LICENSE
 304
 305 Copyright (C) 2016 by Marius Gavrilescu
 306
 307 This library is free software; you can redistribute it and/or modify
 308 it under the same terms as Perl itself, either Perl version 5.22.1 or,
 309 at your option, any later version of Perl 5 you may have available.
 310
 311
 312 =cut