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_002';
  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 sub form_table_row {
  66         my ($data, $tr) = @_;
  67         $tr->fclass($_)->replace_content($data->{$_}) for qw/title subtitle stock/;
  68         $tr->fclass('price')->replace_content(stringify_money $data->{price});
  69         $tr->fclass('title')->attr('data-product', $data->{product});
  70         $tr->fclass('title')->attr('href', '/details/'.$data->{product}.'/'.make_slug $data->{title});
  71 #       $tr->fclass('title')->attr('data-summary', $data->{summary});
  72         $tr->look_down(_tag => 'input')->attr(max => $data->{stock});
  73         $tr->look_down(_tag => 'input')->attr(name => 'quant'.$data->{product});
  74 }
  75
  76 sub form_app {
  77         my ($env) = @_;
  78         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
  79
  80         my $data = $db{$$}->select(products => '*', {}, 'product')->hashes;
  81         my $tree = $form->clone;
  82         $tree->find('tbody')->find('tr')->iter3($data, \&form_table_row);
  83
  84         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
  85 }
  86
  87 sub continue_table_row {
  88         my ($data, $tr) = @_;
  89         $tr->fclass($_)->replace_content($data->{$_}) for qw/title subtitle quantity/;
  90         $tr->fclass('price')->replace_content(stringify_money $data->{subtotal});
  91         $tr->fclass('title')->attr('data-product', $data->{product});
  92 }
  93
  94 sub continue_app {
  95         my ($env) = @_;
  96         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
  97         my $tree = $continue->clone;
  98         my $req = Plack::Request->new($env);
  99         my $params = $req->body_parameters;
 100
 101         my ($quant, $total, @data, @notes);
 102         for (sort keys %$params) {
 103                 next unless /^quant/;
 104                 next unless $params->{$_};
 105                 my $data = $db{$$}->select(products => '*', {product => substr $_, 5})->hash;
 106                 $data->{quantity} = $params->{$_};
 107                 if ($data->{stock} == 0) {
 108                         push @notes, 'Item is out of stock and was removed from order: '.$data->{title};
 109                         next
 110                 }
 111                 if ($data->{quantity} > $data->{stock}) {
 112                         $data->{quantity} = $data->{stock};
 113                         push @notes, 'Not enough units of "'.$data->{title}.'" available. Quantity reduced to '.$data->{quantity}
 114                 }
 115                 $data->{subtotal} = $data->{price} * $data->{quantity};
 116                 $quant += $data->{quantity};
 117                 $total += $data->{subtotal};
 118                 push @data, $data
 119         }
 120
 121         return [500, ['Content-type' => 'text/plain'], ['Error: no items in order.']] unless $quant;
 122
 123         $tree->fid('subtotal')->replace_content(stringify_money $total);
 124         my $dvalue;
 125         if ($params->{discount}) {
 126                 my $discount = $db{$$}->select(discounts => '*', {discount => $params->{discount}})->hash;
 127                 if (!defined $discount) {
 128                         push @notes, 'Discount code incorrect. No discount applied.'
 129                 } elsif ($db{$$}->select(orders => 'COUNT(*)', {discount => $params->{discount}})->list) {
 130                         push @notes, 'Discount code already used once. No discount applied.'
 131                 } else {
 132                         $dvalue = int (0.5 + $discount->{fraction} * $total) if $discount->{fraction};
 133                         $dvalue = $discount->{flat}                          if $discount->{flat};
 134                         $tree->fid('discount')->replace_content('-'.stringify_money $dvalue);
 135                         $total -= $dvalue;
 136                         $tree->look_down(name => 'discount')->attr(value => $params->{discount});
 137                         push @notes, 'Discount applied.'
 138                 }
 139         }
 140         $tree->look_down(name => 'discount')->detach unless $dvalue;
 141         $tree->fid('discount_tr')->detach unless $dvalue;
 142         my $postage = 220 + 50 * $quant;
 143         $tree->fid('postage')->replace_content(stringify_money $postage);
 144         $total += $postage;
 145         $tree->fid('total')->replace_content(stringify_money $total);
 146
 147         $tree->fid('order')->find('tbody')->find('tr')->iter3(\@data, \&continue_table_row);
 148         $tree->iter($tree->fid('notes')->find('li') => @notes);
 149
 150         $tree->look_down(name => 'products')->attr(value => encode_json \@data);
 151         $tree->look_down(name => 'total')->attr(value => $total);
 152
 153         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 154 }
 155
 156 sub order_app {
 157         my ($env) = @_;
 158         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 159         my $tree = $order->clone;
 160         my $req = Plack::Request->new($env);
 161         my ($id) = $env->{PATH_INFO} =~ m,^/([0-9A-F]+),;
 162         if ($id) {
 163                 my $total = $db{$$}->select(orders => 'total', {id => $id})->list;
 164                 $tree->fid('orderid')->replace_content($id);
 165                 $tree->look_down(name => 'order')->attr(value => $id);
 166                 $tree->fid('total')->replace_content(stringify_money $total);
 167                 $tree->find('script')->attr('data-amount', $total);
 168                 return [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 169         } else {
 170                 my %parms = %{$req->body_parameters};
 171                 my $id = sprintf "%X%04X", time, $$;
 172                 my $err;
 173                 try {
 174                         $db{$$}->begin_work;
 175                         my $products = decode_json $req->body_parameters->{products};
 176                         for my $prod (@$products) {
 177                                 my $stock = $db{$$}->select(products => 'stock', {product => $prod->{product}})->list;
 178                                 die "Not enough of " .$prod->{title}."\n" if $prod->{quantity} > $stock;
 179                                 $db{$$}->update(products => {stock => $stock - $prod->{quantity}}, {product => $prod->{product}});
 180                         }
 181                         $db{$$}->insert(orders => {id => $id, %parms});
 182                         $db{$$}->commit;
 183                 } catch {
 184                         $db{$$}->rollback;
 185                         $err = [500, ['Content-type', 'text/plain'], ["Error: $_"]]
 186                 };
 187                 return $err if $err;
 188                 return [303, [Location => "/order/$id"], []]
 189         }
 190 }
 191
 192 sub details_list_element {
 193         my ($data, $li) = @_;
 194         $li->find('a')->attr(href => "/$data");
 195         my $thumb = $data =~ s/fullpics/thumbs/r;
 196         $thumb = $data unless -f $thumb;
 197         $li->find('img')->attr(src => "/$thumb");
 198 }
 199
 200 sub details_app {
 201         my ($env) = @_;
 202         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 203         my $tree = $details->clone;
 204         my ($id) = $env->{PATH_INFO} =~ m,^/(\d+),;
 205         my $title = $db{$$}->select(products => 'title', {product => $id})->list;
 206         my @pics = <static/fullpics/$id-*>;
 207         my $slug = make_slug $title;
 208         $tree->find('title')->replace_content("Pictures of $title | ledparts4you");
 209         $tree->find('h2')->replace_content($title);
 210         $tree->look_down(rel => 'canonical')->attr(href => "/details/$id/$slug");
 211         $tree->fid('pictures')->iter3(\@pics, \&details_list_element);
 212
 213         [200, ['Content-type' => 'text/html; charset=utf-8'], [$tree->as_HTML]]
 214 }
 215
 216 sub pay_app {
 217         my ($env) = @_;
 218         my $req = Plack::Request->new($env);
 219         $db{$$} //= DBIx::Simple->connect($ENV{OOF_DSN} // 'dbi:Pg:');
 220         my $order = $req->body_parameters->{order};
 221         my $token = $req->body_parameters->{stripeToken};
 222         return [500, ['Content-type' => 'text/html; charset=utf-8'], ['No token received, payment did not succeed.']] unless $token;
 223         $db{$$}->update(orders => {stripe_token => $token}, {id => $order});
 224         [200, ['Content-type' => 'text/html; charset=utf-8'], [$pay->as_HTML]];
 225 }
 226
 227 sub app {
 228         my $footer = read_file 'tmpl/footer.html';
 229         builder {
 230                 enable sub {
 231                         my $app = shift;
 232                         sub {
 233                                 my $res = $app->(@_);
 234                                 push @{$res->[2]}, $footer if $res->[0] == 200;
 235                                 $res;
 236                         }
 237                 };
 238                 mount '/' => sub { [301, [Location => '/form'], []] };
 239                 mount '/form'     => \&form_app;
 240                 mount '/continue' => \&continue_app;
 241                 mount '/order'    => \&order_app;
 242                 mount '/details'  => \&details_app;
 243                 mount '/pay'      => \&pay_app;
 244         }
 245 }
 246
 247 1;
 248 __END__
 249
 250 =head1 NAME
 251
 252 App::Web::Oof - Oversimplified order form / ecommerce website
 253
 254 =head1 SYNOPSIS
 255
 256   use App::Web::Oof;
 257
 258 =head1 DESCRIPTION
 259
 260 Oof (Oversimplified order form) is a very simple ecommerce website.
 261 It is the code behind L<https://ledparts4you.uk.to>.
 262
 263 This version is reasonably functional, yet not very reusable, hence
 264 the version number.
 265
 266 =head1 AUTHOR
 267
 268 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 269
 270 =head1 COPYRIGHT AND LICENSE
 271
 272 Copyright (C) 2016 by Marius Gavrilescu
 273
 274 This library is free software; you can redistribute it and/or modify
 275 it under the same terms as Perl itself, either Perl version 5.22.1 or,
 276 at your option, any later version of Perl 5 you may have available.
 277
 278
 279 =cut