factored TFL client

11 files changed, 313 insertions, 0 deletions

diff --git a/lib/WebService/TFL/Bus.pm b/lib/WebService/TFL/Bus.pm
new file mode 100644
index 0000000..60ec5c9
--- /dev/null
+++ b/lib/WebService/TFL/Bus.pm
@@ -0,0 +1,46 @@
+package WebService::TFL::Bus;
+use Moose;
+use Moose::Util::TypeConstraints;
+use MooseX::Types::URI 'Uri';
+use WebService::TFL::Bus::Response;
+use namespace::autoclean;
+
+has user_agent => (
+    isa => duck_type(['get']),
+    is => 'ro',
+    lazy_build => 1,
+);
+sub _build_user_agent {
+    require LWP::UserAgent;
+    my $ua = LWP::UserAgent->new();
+    $ua->env_proxy;
+    return $ua;
+}
+
+has uri => (
+    isa => Uri,
+    is => 'ro',
+    coerce => 1,
+    default => 'http://countdown.api.tfl.gov.uk/interfaces/ura/instant_V1',
+);
+
+sub request {
+    my ($self,$request) = @_;
+
+    my $http_response = $self->user_agent->get(
+        $request->request_uri($self->uri)
+    );
+    if ($http_response->is_success) {
+        my $json = $http_response->content;
+
+        return WebService::TFL::Bus::Response->new_from_json(
+            $request->ReturnList,
+            $json
+        );
+    }
+    else {
+        die $http_response->status_line;
+    }
+}
+
+1;
diff --git a/lib/WebService/TFL/Bus/Fields.pm b/lib/WebService/TFL/Bus/Fields.pm
new file mode 100644
index 0000000..b3d555f
--- /dev/null
+++ b/lib/WebService/TFL/Bus/Fields.pm
@@ -0,0 +1,77 @@
+package WebService::TFL::Bus::Fields;
+use strict;
+use warnings;
+
+sub stop_return_fields {
+    qw(
+          StopPointName
+          StopID
+          StopCode1
+          StopCode2
+          StopPointType
+          Towards
+          Bearing
+          StopPointIndicator
+          StopPointState
+          Latitude
+          Longitude
+  );
+}
+
+sub prediction_return_fields {
+    stop_return_fields(),
+    qw(
+          VisitNumber
+          LineID
+          LineName
+          DirectionID
+          DestinationText
+          DestinationName
+          VehicleID
+          TripID
+          RegistrationNumber
+          EstimatedTime
+          ExpireTime
+  ),
+}
+
+sub flexible_return_fields {
+    stop_return_fields,
+    qw(
+          MessageUUID
+          MessageType
+          MessagePriority
+          MessageText
+          StartTime
+          ExpireTime
+  ),
+}
+
+sub query_fields {
+    qw(
+          StopAlso
+          Circle
+          StopPointName
+          StopID
+          StopCode1
+          StopCode2
+          StopPointType
+          Towards
+          Bearing
+          StopPointIndicator
+          StopPointState
+          VisitNumber
+          LineID
+          LineName
+          DirectionID
+          DestinationText
+          DestinationName
+          VehicleID
+          TripID
+          RegistrationNumber
+          MessageType
+          MessagePriority
+  );
+}
+
+1;
diff --git a/lib/WebService/TFL/Bus/Request.pm b/lib/WebService/TFL/Bus/Request.pm
new file mode 100644
index 0000000..cf35459
--- /dev/null
+++ b/lib/WebService/TFL/Bus/Request.pm
@@ -0,0 +1,37 @@
+package WebService::TFL::Bus::Request;
+use Moose;
+use WebService::TFL::Bus::Fields;
+use namespace::autoclean;
+
+for my $field (WebService::TFL::Bus::Fields->query_fields) {
+    has $field => (
+        is => 'rw',
+        predicate => "has_$field",
+    );
+}
+
+has ReturnList => (
+    is => 'rw',
+    isa => 'ArrayRef',
+    predicate => 'has_ReturnList',
+);
+
+sub request_uri {
+    my ($self,$base_uri) = @_;
+
+    my $uri = $base_uri->clone;
+    my %form;
+    for my $field (WebService::TFL::Bus::Fields->query_fields) {
+        my $pred = "has_$field";
+        if ($self->$pred) {
+            $form{$field} = $self->$field;
+        }
+    }
+    if ($self->has_ReturnList) {
+        $form{ReturnList}=join ',',@{$self->ReturnList}
+    }
+    $uri->query_form(\%form);
+    return $uri;
+}
+
+1;
diff --git a/lib/WebService/TFL/Bus/Response.pm b/lib/WebService/TFL/Bus/Response.pm
new file mode 100644
index 0000000..a4aa056
--- /dev/null
+++ b/lib/WebService/TFL/Bus/Response.pm
@@ -0,0 +1,54 @@
+package WebService::TFL::Bus::Response;
+use Moose;
+use Class::Load 'load_class';
+use JSON;
+use namespace::autoclean;
+
+sub line_class {
+    "WebService::TFL::Bus::Response::$_[0]";
+}
+
+my %line_map = (
+    0 => 'Stop',
+    1 => 'Prediction',
+    2 => 'FlexibleMessage',
+    3 => 'BaseVersion',
+    4 => 'URAVersion',
+);
+
+for my $field (values %line_map) {
+    my $class = line_class($field);
+    load_class($class);
+    has $field => (
+        is => 'ro',
+        isa => "ArrayRef[$class]",
+        traits => [ 'Array' ],
+    );
+}
+
+sub new_from_json {
+    my ($class,$return_list,$json) = @_;
+
+    my $parser = JSON->new->utf8;
+
+    my %return_set;@return_set{@$return_list}=();
+    unless (%return_set) {
+        @return_set{qw(StopPointName LineName EstimatedTime)}=();
+    }
+    my %args;
+
+    while ($json) {
+        my ($array,$consumed) = $parser->decode_prefix($json);
+
+        my $array_type = $line_map{$array->[0]};
+        my $line_class = line_class($array_type);
+        push @{$args{$array_type}},
+            $line_class->new_from_array(\%return_set,$array);
+
+        substr($json,0,$consumed)='';
+    }
+
+    return $class->new(\%args);
+}
+
+1;
diff --git a/lib/WebService/TFL/Bus/Response/BaseVersion.pm b/lib/WebService/TFL/Bus/Response/BaseVersion.pm
new file mode 100644
index 0000000..37b2ddb
--- /dev/null
+++ b/lib/WebService/TFL/Bus/Response/BaseVersion.pm
@@ -0,0 +1,15 @@
+package WebService::TFL::Bus::Response::BaseVersion;
+use Moose;
+use namespace::autoclean;
+
+has Version => (
+    is => 'ro',
+);
+
+sub new_from_array {
+    my ($class,$return_set,$array) = @_;
+
+    return $class->new({Version => $array->[1]});
+}
+
+1;
diff --git a/lib/WebService/TFL/Bus/Response/FlexibleMessage.pm b/lib/WebService/TFL/Bus/Response/FlexibleMessage.pm
new file mode 100644
index 0000000..11b7b1a
--- /dev/null
+++ b/lib/WebService/TFL/Bus/Response/FlexibleMessage.pm
@@ -0,0 +1,5 @@
+package WebService::TFL::Bus::Response::FlexibleMessage;
+use Moose;
+with 'WebService::TFL::Bus::ResponseTypeRole' => { type => 'flexible' };
+
+1;
diff --git a/lib/WebService/TFL/Bus/Response/Prediction.pm b/lib/WebService/TFL/Bus/Response/Prediction.pm
new file mode 100644
index 0000000..d3ea931
--- /dev/null
+++ b/lib/WebService/TFL/Bus/Response/Prediction.pm
@@ -0,0 +1,5 @@
+package WebService::TFL::Bus::Response::Prediction;
+use Moose;
+with 'WebService::TFL::Bus::ResponseTypeRole' => { type => 'prediction' };
+
+1;
diff --git a/lib/WebService/TFL/Bus/Response/Stop.pm b/lib/WebService/TFL/Bus/Response/Stop.pm
new file mode 100644
index 0000000..3c98ca5
--- /dev/null
+++ b/lib/WebService/TFL/Bus/Response/Stop.pm
@@ -0,0 +1,5 @@
+package WebService::TFL::Bus::Response::Stop;
+use Moose;
+with 'WebService::TFL::Bus::ResponseTypeRole' => { type => 'stop' };
+
+1;
diff --git a/lib/WebService/TFL/Bus/Response/URAVersion.pm b/lib/WebService/TFL/Bus/Response/URAVersion.pm
new file mode 100644
index 0000000..38c8a62
--- /dev/null
+++ b/lib/WebService/TFL/Bus/Response/URAVersion.pm
@@ -0,0 +1,17 @@
+package WebService::TFL::Bus::Response::URAVersion;
+use Moose;
+use namespace::autoclean;
+
+for my $field (qw(Version TimeStamp)) {
+    has $field => (
+        is => 'ro',
+    );
+}
+
+sub new_from_array {
+    my ($class,$return_set,$array) = @_;
+
+    return $class->new({Version => $array->[1],TimeStamp => $array->[2]});
+}
+
+1;
diff --git a/lib/WebService/TFL/Bus/ResponseTypeRole.pm b/lib/WebService/TFL/Bus/ResponseTypeRole.pm
new file mode 100644
index 0000000..6cfd460
--- /dev/null
+++ b/lib/WebService/TFL/Bus/ResponseTypeRole.pm
@@ -0,0 +1,40 @@
+package WebService::TFL::Bus::ResponseTypeRole;
+use MooseX::Role::Parameterized;
+use WebService::TFL::Bus::Fields;
+use WebService::TFL::Bus::Types 'DateTimeMillis';
+
+parameter type => (
+    isa => 'Str',
+    required => 1,
+);
+
+role {
+    my $p = shift;
+    my $method = $p->type . '_return_fields';
+    my @fields = WebService::TFL::Bus::Fields->$method;
+
+    for my $field (@fields) {
+        has $field => (
+            is => 'ro',
+            ( $field =~ /Time$/ ? (
+                isa => DateTimeMillis,
+                coerce => 1,
+            ) : () ),
+        );
+    }
+
+    method new_from_array => sub {
+        my ($class,$return_set,$array) = @_;
+
+        my %args;
+        my $i=1;
+        for my $field (@fields) {
+            next unless exists $return_set->{$field};
+            $args{$field}=$array->[$i];
+            ++$i;
+        }
+        return $class->new(\%args);
+    }
+};
+
+1;
diff --git a/lib/WebService/TFL/Bus/Types.pm b/lib/WebService/TFL/Bus/Types.pm
new file mode 100644
index 0000000..9b569f5
--- /dev/null
+++ b/lib/WebService/TFL/Bus/Types.pm
@@ -0,0 +1,12 @@
+package WebService::TFL::Bus::Types;
+use MooseX::Types -declare => [
+    'DateTimeMillis'
+];
+use MooseX::Types::Moose 'Num';
+use MooseX::Types::DateTime 'DateTime';
+
+subtype DateTimeMillis, as DateTime;
+coerce DateTimeMillis, from Num,
+    via { 'DateTime'->from_epoch( epoch => $_ / 1000 ) };
+
+1;