├── .gitignore ├── Changes ├── Dockerfile ├── LICENSE ├── Makefile.PL ├── README.md ├── aptfile ├── bin ├── myriad-dev.pl ├── myriad-migrate-rpc-streams.pl ├── myriad-start.sh └── myriad.pl ├── cpanfile ├── dist.ini ├── example ├── batch-demo.pl ├── lib │ ├── Coffee │ │ ├── Drinker │ │ │ ├── Heavy.pm │ │ │ └── Judge.pm │ │ ├── Manager │ │ │ ├── API.pm │ │ │ ├── Coffee.pm │ │ │ ├── Machine.pm │ │ │ ├── Stats.pm │ │ │ └── User.pm │ │ └── Server │ │ │ └── REST.pm │ └── Example │ │ └── Service │ │ ├── Factor.pm │ │ └── Secret.pm ├── logic-demo.pl ├── rpc-demo.pl ├── use-config.pl └── writing-test.pl ├── lib ├── Myriad.pm ├── Myriad │ ├── API.pm │ ├── Bootstrap.pm │ ├── Class.pm │ ├── Commands.pm │ ├── Config.pm │ ├── Example │ │ ├── Call.pm │ │ ├── Echo.pm │ │ ├── RPC.pm │ │ └── Startup.pm │ ├── Exception.pm │ ├── Exception │ │ ├── Base.pm │ │ ├── Builder.pm │ │ ├── General.pm │ │ └── InternalError.pm │ ├── Guide │ │ └── Tutorial.pod │ ├── Mutex.pm │ ├── Plugin.pm │ ├── RPC.pm │ ├── RPC │ │ ├── Client.pm │ │ ├── Client │ │ │ └── Implementation │ │ │ │ ├── Memory.pm │ │ │ │ └── Redis.pm │ │ ├── Implementation │ │ │ ├── Memory.pm │ │ │ └── Redis.pm │ │ └── Message.pm │ ├── Redis │ │ └── Pending.pm │ ├── Registry.pm │ ├── Role.pm │ ├── Role │ │ ├── RPC.pm │ │ ├── Storage.pm │ │ └── Subscription.pm │ ├── Service.pm │ ├── Service │ │ ├── Attributes.pm │ │ ├── Bus.pm │ │ ├── Implementation.pm │ │ ├── Remote.pm │ │ ├── Remote │ │ │ ├── Bus.pm │ │ │ └── RPC.pm │ │ ├── Storage.pm │ │ └── Storage │ │ │ └── Remote.pm │ ├── Storage.pm │ ├── Storage │ │ └── Implementation │ │ │ ├── Memory.pm │ │ │ └── Redis.pm │ ├── Subscription.pm │ ├── Subscription │ │ └── Implementation │ │ │ ├── Memory.pm │ │ │ └── Redis.pm │ ├── Transport │ │ ├── HTTP.pm │ │ ├── Memory.pm │ │ └── Redis.pm │ ├── UI │ │ └── Readline.pm │ └── Util │ │ ├── Defer.pm │ │ ├── Secret.pm │ │ └── UUID.pm ├── Test │ ├── Myriad.pm │ └── Myriad │ │ └── Service.pm └── yriad.pm ├── pod-inherit.patch ├── script └── update-cpanfile.pl ├── t ├── RPC │ ├── full-cycle.t │ ├── memory.t │ ├── message.t │ ├── multiple-rpcs.t │ ├── overflow-protection.t │ └── pending-requests.t ├── Subscription │ ├── full-cycle.t │ ├── multi-sub.t │ └── transport-relation.t ├── batch.t ├── bootstrap.t ├── class.t ├── commands.t ├── config.t ├── config.yml ├── defer-attrib.t ├── define_role.t ├── exception.t ├── myriad.t ├── redis.t ├── registry.t ├── role.t ├── service-bus.t ├── service-lifecycle.t ├── storage.t ├── syntax.t ├── transport │ └── memory.t └── util │ └── secret.t └── xt └── memory-leak.t /.gitignore: -------------------------------------------------------------------------------- 1 | !Build/ 2 | .last_cover_stats 3 | /META.yml 4 | /META.json 5 | /MYMETA.* 6 | *.o 7 | *.pm.tdy 8 | *.bs 9 | 10 | # Devel::Cover 11 | cover_db/ 12 | 13 | # Devel::NYTProf 14 | nytprof.out 15 | 16 | # Dizt::Zilla 17 | /.build/ 18 | 19 | # Module::Build 20 | _build/ 21 | Build 22 | Build.bat 23 | 24 | # Module::Install 25 | inc/ 26 | 27 | # ExtUtils::MakeMaker 28 | /blib/ 29 | /_eumm/ 30 | /*.gz 31 | /Makefile 32 | /Makefile.old 33 | /MANIFEST.bak 34 | /pm_to_blib 35 | /*.zip 36 | 37 | # IDEs ( Some people !) 38 | .idea 39 | *.swp 40 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | 2 | Revision history for {{$dist->name}} 3 | 4 | {{$NEXT}} 5 | [Dependencies] 6 | - Future::AsyncAwait - updated to v0.61 for some minor bugfixes and Future::XS 7 | compatibility 8 | 9 | [New features] 10 | - support for Net::Async::Redis::XS, set the environment variable `PERL_REDIS_XS` to `1` 11 | to load and use the XS versions for better performance 12 | - Future::AsyncAwait::Hooks now available (for suspend/resume blocks) when using `:v2` 13 | 14 | [Bugs fixed] 15 | - handle keyspace notifications properly for config changes in Redis 16 | 17 | 1.001 2022-11-11 09:42:07+08:00 Asia/Singapore 18 | [Bugs fixed] 19 | - Latest Future (and Future::XS) were failing tests due to `Future->needs_all` 20 | being a class method, the test was incorrectly trying to use it as a plain function 21 | (only affects the memory transport, not Redis) 22 | 23 | 1.000 2022-09-05 10:25:25+08:00 Asia/Singapore 24 | [API changes] 25 | - The --service_name parameter has been dropped, since it makes no sense when 26 | used with multiple services or instances 27 | 28 | [New features] 29 | - Thanks to Syntax::Keyword::Equ, match() now supports `equ` as an operator 30 | - RPC on start handle existing pending messages in stream, if not expired. 31 | - RPC overflow protection (will not connsume more than it can process). 32 | - Transport Redis connection pool count and wait time can be controlled through config parameters. 33 | - Add orderedset data structure to Myriad storage. 34 | 35 | [Bugs fixed] 36 | - Subscriptions to create streams from source without a published event. 37 | 38 | [Dependencies] 39 | - Object::Pad - updated to v0.55 for various bugfixes and improvements 40 | 41 | 0.010 2021-07-22 07:14:15+00:00 UTC 42 | [New features] 43 | - Metrics adapter type is now configurable using --metrics_adapter. 44 | - Metrics destination can be changed using --metrics_host and --metrics_port. 45 | 46 | [Bugs fixed] 47 | - RPC client to track message id for response before sending it. 48 | - Subscription to use the right group name to acknowledge from stream. 49 | 50 | [Dependencies] 51 | - Object::Pad - use new ->begin_class from MOB package. 52 | - Metrics::Any - update to v0.07 to disable metrics from certain packages. 53 | - Metrics::Any::Adapter::Statsd - instead of DogStatsd standard. 54 | 55 | 0.009 2021-07-14 18:39:34+08:00 Asia/Kuala_Lumpur 56 | [API Changes] 57 | - Syntax::Keyword::Match is now imported in Myriad::Service code 58 | - Redis: A service will not create another service's stream. 59 | - Allow service namespaces by adding '::*' to the startup command. 60 | 61 | [New features] 62 | - Added incr method for storage keys. 63 | 64 | 0.008 2021-06-18 05:24:31+00:00 UTC 65 | [API Changes] 66 | - Breaking: RPC client will unwrap the extra 'response' level from the response. 67 | - Myriad now has run_future like shutdown_future, to tell when the framework is running. 68 | - Test::Myriad has a ready sub, to tell when the underlying Myriad is running. 69 | - Batch will now throw an exception and fail if the developer didn't return arrayref. 70 | 71 | [Bugs fixed] 72 | - Having multiple RPC added will not block and wait each others from reading from stream. 73 | 74 | 0.007 2021-05-21 14:22:03+00:00 UTC 75 | [Bugs fixed] 76 | - RPC reading multiple items from stream but processing only one. 77 | 78 | [Dependencies] 79 | - Object::Pad - Use officially documented way to obtain metaclasses. 80 | 81 | 0.006 2021-05-07 04:16:11+00:00 UTC 82 | [API Changes] 83 | - `fmap_void`, `fmap_concat` and `fmap_scalar` are imported from Future::Utils into classes by default 84 | - RPC streams are now organized differently - there will be a stream for each method 85 | instead of one stream per service. To migrate, use the script in `bin/myriad-migrate-rpc-streams.pl` 86 | 87 | [Bugs fixed] 88 | - RPC reads no longer not block each other when multiple services have been loaded into one Myriad 89 | process 90 | 91 | 0.005 2021-04-30 12:52:41+00:00 UTC 92 | [Bugs fixed] 93 | - small memory leak due to defer blocks not being cleared up, now uses try/finally 94 | to avoid this 95 | - minor issues in command line parser for services' config 96 | - bootstrap test to be skipped if Linux::Inotify2 is not available 97 | 98 | 0.004 2021-04-28 13:27:36+08:00 Asia/Kuala_Lumpur 99 | [API Changes] 100 | - Helper methods from List::Util - `min`, `max` and `sum0` - plus JSON functions 101 | from JSON::MaybeUTF8 now injected into classes by default 102 | - `defer` keyword from Syntax::Keyword::Defer is also injected into classes by default 103 | 104 | [Bugs fixed] 105 | - `memory` transport was not delivering messages correctly due to a double-counting bug 106 | - Redis stream cleanup fixed 107 | 108 | 0.003 2021-04-27 14:57:49+08:00 Asia/Kuala_Lumpur 109 | [Bugs fixed] 110 | - updates to latest Net::Async::Redis to resolve remaining memory leaks 111 | - numeric configuration values were treated as booleans if the default was set to zero 112 | 113 | 0.002 2021-04-24 16:36:44+08:00 Asia/Kuala_Lumpur 114 | [API Changes] 115 | - The "perl" transport has been renamed to "memory", for consistency 116 | with implementations in other languages 117 | - Startup and shutdown calls now receive the `$myriad` instance as the 118 | first parameter for convenience, and can be method calls (e.g. Myriad.pm 119 | method name) instead of plain coderefs 120 | 121 | [New features] 122 | - Subscription to configuration changes via the Redis transport - configuration 123 | objects still use Ryu::Observable so this behaviour should be a seamless upgrade 124 | for existing code 125 | 126 | [Bugs fixed] 127 | - Batch handling had a memory leak, this version should be improved 128 | although `await` calls inside a batch method may still exhibit 129 | increased memory usage (we expect to address this in the next version) 130 | 131 | 0.001 2021-04-16 09:25:26+08:00 Asia/Kuala_Lumpur 132 | 133 | Initial release. 134 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM deriv/dzil 2 | ARG HTTP_PROXY 3 | 4 | WORKDIR /app 5 | # Conditional copy - we want whichever files exist, and we'd typically expect to see at least one 6 | ONBUILD COPY aptfil[e] cpanfil[e] dist.in[i] /app/ 7 | ONBUILD RUN prepare-apt-cpan.sh \ 8 | && dzil authordeps | cpanm -n 9 | ONBUILD COPY . /app/ 10 | ONBUILD RUN if [ -f /app/app.pl ]; then perl -I /app/lib -c /app/app.pl; fi 11 | 12 | RUN dzil install \ 13 | && dzil clean \ 14 | && git clean -fd \ 15 | && apt purge --autoremove -y \ 16 | && rm -rf .git 17 | 18 | ENTRYPOINT [ "bin/myriad-start.sh" ] 19 | 20 | -------------------------------------------------------------------------------- /aptfile: -------------------------------------------------------------------------------- 1 | build-essential 2 | krb5-config 3 | libidn2-dev 4 | pkg-config 5 | libtool-bin 6 | libc-dev 7 | git 8 | make 9 | cmake 10 | libprotoc-dev 11 | -------------------------------------------------------------------------------- /bin/myriad-dev.pl: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | # Run Myriad with the hot reload feature on!. 4 | 5 | use strict; 6 | use warnings; 7 | use Myriad::Bootstrap; 8 | 9 | 10 | Myriad::Bootstrap->boot('Myriad'); 11 | 12 | -------------------------------------------------------------------------------- /bin/myriad-migrate-rpc-streams.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # Basic usage: myriad-migrate-rpc-streams.pl --uri --service 4 | # This script will move messages from the old single rpc stream into multiple streams 5 | # it won't delete the original stream. 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use Getopt::Long; 11 | 12 | use IO::Async::Loop; 13 | use Future::AsyncAwait; 14 | 15 | use Net::Async::Redis; 16 | use Net::Async::Redis::Cluster; 17 | 18 | use URI; 19 | use Syntax::Keyword::Try; 20 | use Log::Any qw($log); 21 | use Log::Any::Adapter qw(Stderr), log_level => 'info'; 22 | 23 | my $uri; 24 | my $is_cluster = 0; 25 | my $service_name; 26 | 27 | GetOptions( 28 | 'uri=s' => \$uri, 29 | 'service=s' => \$service_name, 30 | 'cluster' => \$is_cluster, 31 | ) or die "usage $0 --uri --service [--cluster]"; 32 | 33 | $uri = URI->new($uri); 34 | $service_name =~ s/::/./; 35 | $service_name = lc($service_name); 36 | 37 | my $loop = IO::Async::Loop->new(); 38 | 39 | my $redis; 40 | 41 | if ($is_cluster) { 42 | $loop->add( 43 | $redis = Net::Async::Redis::Cluster->new 44 | ); 45 | await $redis->bootstrap( 46 | host => $uri->host, 47 | port => $uri->port, 48 | ); 49 | } else { 50 | $loop->add( 51 | $redis = Net::Async::Redis->new(uri => $uri) 52 | ); 53 | } 54 | 55 | my $old_rpc_stream = "myriad.service.$service_name/rpc"; 56 | my $new_rpc_stream_prefix = "myriad.service.$service_name.rpc/"; 57 | 58 | unless ( await $redis->exists($old_rpc_stream) ) { 59 | $log->fatalf('Cannot find old rpc stream for service %s', $service_name); 60 | exit 1; 61 | } 62 | 63 | try { 64 | await $redis->xgroup('CREATE', $old_rpc_stream, 'rpc_migration', 0); 65 | } catch ($e) { 66 | if ($e =~ /BUSYGROUP/) { 67 | $log->fatalf('Got a busygroup for stream %s are you running another migration?', $old_rpc_stream); 68 | } else { 69 | $log->fatalf('Failed to create group for stream %s - %s', $old_rpc_stream, $e); 70 | } 71 | exit 1; 72 | } 73 | 74 | try { 75 | while (my ($batch) = await $redis->xreadgroup( 76 | GROUP => 'rpc_migration', 'migrator', 77 | COUNT => 50, 78 | STREAMS => ($old_rpc_stream, '>'), 79 | )) { 80 | last unless $batch->@*; 81 | my ($stream, $messages) = $batch->[0]->@*; 82 | for my $message ($messages->@*) { 83 | my ($id, $info) = $message->@*; 84 | my %args = $info->@*; 85 | my $stream = $new_rpc_stream_prefix . $args{rpc}; 86 | 87 | await $redis->xadd( 88 | $stream => '*', 89 | %args 90 | ); 91 | } 92 | } 93 | } catch ($e) { 94 | $log->errorf('Error while migrating streams - %s', $e); 95 | } 96 | 97 | await $redis->xgroup('destroy', $old_rpc_stream, 'rpc_migration'); 98 | -------------------------------------------------------------------------------- /bin/myriad-start.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | _term() { 4 | kill -TERM "$myriad" 2>/dev/null 5 | wait "$myriad" 6 | } 7 | 8 | _int() { 9 | kill -INT "$myriad" 2>/dev/null 10 | wait "$myriad" 11 | } 12 | 13 | _quit() { 14 | kill -QUIT "$myriad" 2>/dev/null 15 | wait "$myriad" 16 | } 17 | 18 | trap _term SIGTERM 19 | trap _int SIGINT 20 | trap _quit SIGQUIT 21 | 22 | if [ ! -z $MYRIAD_DEV ] 23 | then 24 | myriad-dev.pl $@ & 25 | else 26 | myriad.pl $@ & 27 | fi 28 | 29 | myriad=$! 30 | wait "$myriad" 31 | -------------------------------------------------------------------------------- /bin/myriad.pl: -------------------------------------------------------------------------------- 1 | #!perl 2 | use strict; 3 | use warnings; 4 | 5 | =head1 NAME 6 | 7 | myriad.pl 8 | 9 | =head1 DESCRIPTION 10 | 11 | =cut 12 | 13 | use Myriad; 14 | use Future::AsyncAwait; 15 | use Time::Moment; 16 | use Syntax::Keyword::Try; 17 | use Sys::Hostname qw(hostname); 18 | 19 | use Log::Any::Adapter qw(Stderr), log_level => 'info'; 20 | use Log::Any qw($log); 21 | 22 | binmode STDIN, ':encoding(UTF-8)'; 23 | binmode STDOUT, ':encoding(UTF-8)'; 24 | binmode STDERR, ':encoding(UTF-8)'; 25 | 26 | try { 27 | my $hostname = hostname(); 28 | $log->infof('Starting Myriad on %s pid %d at %s', $hostname, $$, Time::Moment->now->to_string); 29 | my $myriad = Myriad->new( 30 | hostname => hostname(), 31 | pid => $$, 32 | ); 33 | await $myriad->configure_from_argv(@ARGV); 34 | await $myriad->run; 35 | } catch ($e) { 36 | $log->errorf('%s failed due to %s', $0, $e); 37 | } 38 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | # Syntax 2 | requires 'meta', '>= 0.008'; 3 | requires 'mro'; 4 | requires 'indirect'; 5 | requires 'multidimensional'; 6 | requires 'bareword::filehandles'; 7 | requires 'experimental', '>= 0.032'; 8 | requires 'XS::Parse::Keyword', '>= 0.44'; 9 | requires 'Syntax::Keyword::Dynamically', '>= 0.13'; 10 | requires 'Syntax::Keyword::Try', '>= 0.29'; 11 | requires 'Syntax::Keyword::Defer', '>= 0.10'; 12 | requires 'Syntax::Keyword::Match', '>= 0.15'; 13 | requires 'Syntax::Operator::Equ', '>= 0.10'; 14 | requires 'Future', '>= 0.51'; 15 | requires 'Future::Queue', '>= 0.52'; 16 | requires 'Future::AsyncAwait', '>= 0.66'; 17 | requires 'Future::AsyncAwait::Hooks', '>= 0.02'; 18 | requires 'Future::IO', '>= 0.15'; 19 | requires 'XS::Parse::Sublike', '>= 0.34'; 20 | requires 'Object::Pad', '>= 0.817'; 21 | requires 'Role::Tiny', '>= 2.002004'; 22 | requires 'Data::Checks', '>= 0.09'; 23 | requires 'Object::Pad::FieldAttr::Checked'; 24 | requires 'Object::Pad::FieldAttr::Final', '>= 0.06'; 25 | requires 'Object::Pad::FieldAttr::Isa', '>= 0.05'; 26 | requires 'Object::Pad::FieldAttr::Trigger', '>= 0.07'; 27 | requires 'Object::Pad::FieldAttr::LazyInit', '>= 0.07'; 28 | requires 'Object::Pad::Operator::Of', '>= 0.01'; 29 | requires 'Object::Pad::LexicalMethods', '>= 0.01'; 30 | requires 'Object::Pad::Keyword::Accessor', '>= 0.03'; 31 | requires 'Sublike::Extended'; 32 | requires 'Signature::Attribute::Checked', '>= 0.06'; 33 | requires 'Attribute::Storage', '>= 0.12'; 34 | # Streams 35 | requires 'Ryu', '>= 4.000'; 36 | requires 'Ryu::Async', '>= 0.020'; 37 | # IO::Async 38 | requires 'Heap', '>= 0.80'; 39 | requires 'IO::Async', '>= 0.803'; 40 | requires 'IO::Async::Notifier', '>= 0.803'; 41 | requires 'IO::Async::Test', '>= 0.803'; 42 | requires 'IO::Async::SSL', '>= 0.25'; 43 | # Functionality 44 | requires 'curry', '>= 2.000001'; 45 | requires 'Log::Any', '>= 1.717'; 46 | requires 'Log::Any::Adapter', '>= 1.717'; 47 | requires 'Config::Any', '>= 0.33'; 48 | requires 'YAML::XS', '>= 0.89'; 49 | requires 'Metrics::Any', '>= 0.10'; 50 | requires 'OpenTracing::Any', '>= 1.006'; 51 | requires 'OpenTelemetry', '>= 0.023'; 52 | requires 'OpenTelemetry::SDK', '>= 0.022'; 53 | requires 'OpenTelemetry::Exporter::OTLP', '>= 0.017'; 54 | # Older versions of the protobuf library get confused by perl 5.38 boolean values in the tests 55 | requires 'Alien::ProtoBuf'; 56 | requires 'Alien::uPB::Core'; 57 | requires 'Google::ProtocolBuffers::Dynamic', '>= 0.43'; 58 | requires 'JSON::MaybeUTF8', '>= 2.000'; 59 | requires 'Unicode::UTF8'; 60 | requires 'Time::Moment', '>= 0.44'; 61 | requires 'Sys::Hostname'; 62 | requires 'Pod::Simple::Text'; 63 | requires 'Scope::Guard'; 64 | requires 'Check::UnitCheck'; 65 | requires 'Class::Method::Modifiers'; 66 | requires 'Module::Load'; 67 | requires 'Module::Runtime'; 68 | requires 'Module::Pluggable::Object'; 69 | requires 'Math::Random::Secure'; 70 | requires 'Getopt::Long'; 71 | requires 'Pod::Usage'; 72 | requires 'List::Util', '>= 1.63'; 73 | requires 'List::Keywords', '>= 0.11'; 74 | requires 'Compress::Zstd', '>= 0.20'; 75 | # Integration 76 | requires 'Net::Async::OpenTracing', '>= 1.001'; 77 | requires 'Log::Any::Adapter::OpenTracing', '>= 0.001'; 78 | requires 'Metrics::Any::Adapter::Statsd', '>= 0.03'; 79 | # Transport 80 | requires 'Net::Async::Redis', '>= 6.005'; 81 | recommends 'Net::Async::Redis::XS', '>= 1.001'; 82 | requires 'Net::Async::HTTP', '>= 0.49'; 83 | requires 'Net::Async::HTTP::Server', '>= 0.14'; 84 | # Introspection 85 | requires 'Devel::MAT::Dumper'; 86 | 87 | # Things that may move out 88 | recommends 'Term::ReadLine'; 89 | recommends 'Linux::Inotify2'; 90 | 91 | on 'test' => sub { 92 | requires 'Test::More', '>= 0.98'; 93 | requires 'Test::Deep', '>= 1.130'; 94 | requires 'Test::Fatal', '>= 0.014'; 95 | requires 'Test::MemoryGrowth', '>= 0.03'; 96 | requires 'Log::Any::Adapter::TAP'; 97 | requires 'Log::Any::Test'; 98 | requires 'Test::CheckDeps'; 99 | requires 'Test::NoTabs'; 100 | requires 'Test::MockModule'; 101 | requires 'Test::MockObject'; 102 | }; 103 | 104 | on 'develop' => sub { 105 | requires 'Devel::Cover::Report::Coveralls', '>= 0.11'; 106 | requires 'Devel::Cover'; 107 | }; 108 | 109 | -------------------------------------------------------------------------------- /dist.ini: -------------------------------------------------------------------------------- 1 | name = Myriad 2 | author = Deriv Services Ltd 3 | license = Perl_5 4 | copyright_holder = Deriv Services Ltd 5 | copyright_year = 2020 6 | main_module = lib/Myriad.pm 7 | 8 | [@Author::DERIV] 9 | -remove = AutoPrereqs 10 | max_target_perl = 5.028 11 | -------------------------------------------------------------------------------- /example/batch-demo.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | use Myriad; 6 | 7 | { 8 | package Example::Service::Batch; 9 | 10 | # Simple batch method example. 11 | 12 | use Myriad::Service; 13 | 14 | field $count = 0; 15 | 16 | async method current : RPC { 17 | return $count; 18 | } 19 | 20 | async method next_batch : Batch { 21 | return [ $count++ ]; 22 | } 23 | 24 | } 25 | 26 | no indirect; 27 | 28 | use Syntax::Keyword::Try; 29 | use Future::AsyncAwait; 30 | use Log::Any qw($log); 31 | use Test::More; 32 | 33 | (async sub { 34 | my $myriad = Myriad->new; 35 | $myriad->add_service( 36 | 'Example::Service::Batch', 37 | name => 'example_service_batch', 38 | ); 39 | { 40 | my $srv = $myriad->service_by_name('example_service_batch'); 41 | is(await $srv->current, 1, 'probably already at 1 because the first batch would have been called already'); 42 | # Defer one iteration on the event loop 43 | await $myriad->loop->delay_future(after => 0); 44 | is(await $srv->current, 2, 'and now maybe we have 2'); 45 | } 46 | })->()->get; 47 | 48 | done_testing(); 49 | -------------------------------------------------------------------------------- /example/lib/Coffee/Drinker/Heavy.pm: -------------------------------------------------------------------------------- 1 | package Coffee::Drinker::Heavy; 2 | 3 | use Myriad::Service; 4 | 5 | use JSON::MaybeUTF8 qw(:v1); 6 | use String::Random; 7 | use Future::Utils qw( fmap_concat fmap_void ); 8 | 9 | field $rng = String::Random->new; 10 | field $latest_user_id; 11 | field $latest_machine_id; 12 | 13 | async method startup () { 14 | my $user_storage = $api->service_by_name('coffee.manager.user')->storage; 15 | my $machine_storage = $api->service_by_name('coffee.manager.machine')->storage; 16 | 17 | $latest_user_id = await $user_storage->get('id'); 18 | $latest_machine_id = await $machine_storage->get('id'); 19 | 20 | } 21 | 22 | async method drink : Batch () { 23 | my $coffee_service = $api->service_by_name('coffee.manager.coffee'); 24 | my @got_coffees; 25 | my $concurrent = int(rand(51)); 26 | if ( $latest_user_id > 2 and $latest_machine_id > 2 ) { 27 | my $get_coffee_params = sub { return { int(rand($latest_user_id)) => int(rand($latest_machine_id)) } }; 28 | my $requests = [ map { $get_coffee_params->() } (0..$concurrent) ]; 29 | $log->warnf('Bought Coffee User: %d | Machine: %d | entry_id: %d', $get_coffee_params->()); 30 | @got_coffees = await &fmap_concat( $self->$curry::curry(async method ($params) { 31 | my $r = await $coffee_service->call_rpc('buy', 32 | type => 'PUT', 33 | params => $params 34 | ); 35 | $log->warnf('Bought Coffee User: %d | Machine: %d | entry_id: %d', $params->%*, $r->{id}); 36 | #push @got_coffees, $r; 37 | $r; 38 | }), foreach => $requests, concurrent => $concurrent); 39 | } 40 | return [ @got_coffees ]; 41 | 42 | } 43 | 44 | async method new_drinker : Batch () { 45 | my $user_service = $api->service_by_name('coffee.manager.user'); 46 | my $concurrent = int(rand(51)); 47 | my $requests = [ map { {login => $rng->randpattern("CccccCcCC"), password => 'pass', email => $rng->randpattern("CCCccccccc")} } (0..$concurrent) ]; 48 | my @added_users = await &fmap_concat( $self->$curry::curry(async method ($user_hash) { 49 | my $r = await $user_service->call_rpc('request', 50 | type => 'PUT', 51 | body => $user_hash 52 | ); 53 | $log->warnf('Added User: %s', $r); 54 | $latest_user_id = $r->{id}; 55 | $r; 56 | }), foreach => $requests, concurrent => $concurrent); 57 | 58 | return [ @added_users ]; 59 | 60 | } 61 | 62 | async method new_machine : Batch () { 63 | my $machine_service = $api->service_by_name('coffee.manager.machine'); 64 | my $concurrent = int(rand(51)); 65 | my $requests = [ map { {name => $rng->randpattern("Ccccccccc"), caffeine => $rng->randpattern("n")} } (0..$concurrent) ]; 66 | my @added_machines = await &fmap_concat( $self->$curry::curry(async method ($machine_hash) { 67 | my $r = await $machine_service->call_rpc('request', 68 | type => 'PUT', 69 | body => $machine_hash 70 | ); 71 | $log->warnf('Added Machine %s | %s', $r, $machine_hash); 72 | $latest_machine_id = $r->{id}; 73 | $r; 74 | }), foreach => $requests, concurrent => $concurrent); 75 | 76 | return [ @added_machines ]; 77 | } 78 | 79 | 1; 80 | -------------------------------------------------------------------------------- /example/lib/Coffee/Drinker/Judge.pm: -------------------------------------------------------------------------------- 1 | package Coffee::Drinker::Judge; 2 | 3 | use Myriad::Service; 4 | 5 | use Time::Moment; 6 | use IO::Async::Timer::Periodic; 7 | 8 | field $current_users; 9 | field $current_machines; 10 | field $current_coffee; 11 | field $start_time; 12 | field $timer; 13 | 14 | async method startup () { 15 | $current_users = []; 16 | $current_machines = []; 17 | $current_coffee = []; 18 | $start_time = Time::Moment->now; 19 | 20 | $self->add_child( 21 | $timer = IO::Async::Timer::Periodic->new( 22 | interval => 4, 23 | on_tick => sub { 24 | my $now = Time::Moment->now; 25 | 26 | $log->infof('Running for: %d (seconds)', $start_time->delta_seconds($now) ); 27 | $log->infof('Current Count: Users: %d | Machines: %d | Coffee: %d', scalar @$current_users, scalar @$current_machines, scalar @$current_coffee); 28 | }, 29 | ) 30 | ); 31 | $timer->start; 32 | } 33 | 34 | async method drinking_tracker : Receiver(service => 'coffee.drinker.heavy', channel => 'drink') ($sink) { 35 | return $sink->map(sub { 36 | my $coffee = shift; 37 | $log->infof('GOT COFFEE %s', $coffee); 38 | push @$current_coffee, $coffee; 39 | }); 40 | } 41 | 42 | async method drinkers_tracker : Receiver(service => 'coffee.drinker.heavy', channel => 'new_drinker') ($sink) { 43 | return $sink->map(sub { 44 | my $user = shift; 45 | $log->infof('GOT new Drinker %s', $user); 46 | push @$current_users, $user; 47 | }); 48 | } 49 | 50 | async method machine_tracker : Receiver(service => 'coffee.drinker.heavy', channel => 'new_machine') ($sink) { 51 | return $sink->map(sub { 52 | my $machine = shift; 53 | $log->infof('GOT new MACHINE %s', $machine); 54 | push @$current_machines, $machine; 55 | }); 56 | } 57 | 1; 58 | -------------------------------------------------------------------------------- /example/lib/Coffee/Manager/API.pm: -------------------------------------------------------------------------------- 1 | package Coffee::Manager::API; 2 | 3 | use Myriad::Service; 4 | use Coffee::Server::REST; 5 | 6 | field $http_server; 7 | field $ryu; 8 | field $running_sink; 9 | 10 | async method startup () { 11 | $self->add_child( 12 | $ryu = Ryu::Async->new() 13 | ); 14 | $self->add_child( 15 | $http_server = Coffee::Server::REST->new(listen_port => 80) 16 | ); 17 | 18 | my $sink = $ryu->sink(label => "http_requests_sink"); 19 | $running_sink = $sink->source->map( 20 | $self->$curry::weak(async method ($incoming_req) { 21 | my $req = delete $incoming_req->{request}; 22 | $log->debugf('Incoming request to http_requests_sink | %s', $incoming_req); 23 | try { 24 | my $service_response = await $self->request_service($incoming_req); 25 | if ( exists $service_response->{error} ) { 26 | $http_server->reply_fail($req, $service_response->{error}); 27 | } else { 28 | $http_server->reply_success($req, $service_response); 29 | } 30 | } catch ($e) { 31 | $log->warnf('Outgoing failed reply to HTTP request %s', $e); 32 | $http_server->reply_fail($req, $e); 33 | } 34 | } 35 | ))->resolve->completed; 36 | await $http_server->start($sink); 37 | } 38 | 39 | async method request_service ($incoming_req) { 40 | # In fact hash can be passed as it is, however it is kept for clarity. 41 | my ($service_name, $method, $params, $body, $type) = @$incoming_req{qw(service method params body type)}; 42 | my $service = $api->service_by_name(join '.', 'coffee.manager', $service_name); 43 | return await $service->call_rpc($method, params => $params, body => $body, type => $type); 44 | } 45 | 46 | 1; 47 | -------------------------------------------------------------------------------- /example/lib/Coffee/Manager/Coffee.pm: -------------------------------------------------------------------------------- 1 | package Coffee::Manager::Coffee; 2 | 3 | use Myriad::Service; 4 | 5 | use JSON::MaybeUTF8 qw(:v1); 6 | use Time::Moment; 7 | use Ryu::Source; 8 | 9 | field $fields; 10 | field $last_id; 11 | field $new_coffee_handler = Ryu::Source->new; 12 | 13 | BUILD (%args) { 14 | $fields = { 15 | user => { 16 | mandatory => 1, 17 | entity => 1, 18 | }, 19 | machine => { 20 | mandatory => 1, 21 | entity => 1, 22 | }, 23 | timestamp => { 24 | isa => 'Time::Moment', # some type casting can be implemented 25 | }, 26 | }; 27 | } 28 | 29 | async method startup () { 30 | $last_id = await $api->storage->get('id'); 31 | } 32 | 33 | async method next_id () { 34 | my $id = await $api->storage->incr('id'); 35 | $last_id = $id; 36 | return $id; 37 | } 38 | 39 | async method buy : RPC (%args) { 40 | $log->infof('GOT Coffee buy Request: %s', \%args); 41 | 42 | my $storage = $api->storage; 43 | if ( $args{type} eq 'PUT' or $args{type} eq 'POST' or $args{type} eq 'GET' ) { 44 | # Parse arguments and parameters and accept them in various ways. 45 | my %input; 46 | 47 | my @param = $args{params}->%*; 48 | @input{qw(user machine)} = @param; 49 | 50 | try { 51 | $input{timestamp} = Time::Moment->from_string($args{body}->{timestamp}) if exists $args{body}->{timestamp}; 52 | } catch ($e) { 53 | return {error => {text => 'Invalid timestamp format', code => 400 } }; 54 | } 55 | # set timestamp if not supplied. 56 | $input{timestamp} = Time::Moment->now unless exists $input{timestamp}; 57 | 58 | return {error => {text => 'Missing Argument. Must supply user, machine', code => 400 } } 59 | if grep { ! exists $input{$_} } keys $fields->%*; 60 | 61 | # Get entities details: 62 | # should be converted to fmap instead of for 63 | for my $entity (grep { exists $fields->{$_}{entity}} keys $fields->%*) { 64 | my $service_storage = $api->service_by_name(join('.', 'coffee.manager', $entity))->storage; 65 | my $raw_d = await $service_storage->hash_get($entity, $input{$entity}); 66 | my $data = decode_json_utf8($raw_d); 67 | # Only if found 68 | delete $data->{id}; 69 | if ( grep { defined } values %$data ) { 70 | $input{$entity.'_'.$_} = $data->{$_} for keys %$data; 71 | # since we have it all added 72 | $input{$entity.'_id'} = delete $input{$entity}; 73 | } else { 74 | return {error => {text => 'Invalid User or Machine does not exist', code => 400 } }; 75 | } 76 | } 77 | $input{timestamp} = $input{timestamp}->epoch; 78 | $log->debugf('ARGS: %s', \%input); 79 | 80 | my $id = await $self->next_id; 81 | await $storage->hash_set('coffee', $id, encode_json_utf8(\%input)); 82 | $log->infof('bought new coffee with id: %d | %s', $id, \%input); 83 | my $coffee = {id => $id, %input}; 84 | $new_coffee_handler->emit($coffee); 85 | return $coffee; 86 | } 87 | 88 | } 89 | 90 | async method new_coffee : Emitter() ($source){ 91 | $new_coffee_handler->each(sub { 92 | my $coffee = shift; 93 | $source->emit($coffee); 94 | }); 95 | } 96 | 97 | 1; 98 | -------------------------------------------------------------------------------- /example/lib/Coffee/Manager/Machine.pm: -------------------------------------------------------------------------------- 1 | package Coffee::Manager::Machine; 2 | 3 | use Myriad::Service; 4 | 5 | use JSON::MaybeUTF8 qw(:v1); 6 | use Ryu::Source; 7 | 8 | field $fields; 9 | field $last_id; 10 | field $new_machine_handler = Ryu::Source->new; 11 | 12 | BUILD (%args) { 13 | $fields = { 14 | name => { 15 | mandatory => 1, # not required 16 | unique => 1, # not required 17 | }, 18 | caffeine => { 19 | mandatory => 1, # not required 20 | }, 21 | }; 22 | } 23 | 24 | async method startup () { 25 | $last_id = await $api->storage->get('id'); 26 | } 27 | 28 | async method next_id () { 29 | my $id = await $api->storage->incr('id'); 30 | $last_id = $id; 31 | return $id; 32 | } 33 | 34 | async method request : RPC (%args) { 35 | $log->infof('GOT Machine Request: %s', \%args); 36 | 37 | my $storage = $api->storage; 38 | # Only accept PUT request 39 | if ( $args{type} eq 'PUT' or $args{type} eq 'POST') { 40 | my %body = $args{body}->%*; 41 | return {error => {text => 'Missing Argument. Must supply login, password, email', code => 400 } } 42 | if grep { ! exists $body{$_} } keys $fields->%*; 43 | 44 | my %unique_values; 45 | # should be converted to fmap instead of for 46 | for my $unique_field (grep { exists $fields->{$_}{unique}} keys $fields->%*) { 47 | my $value = await $storage->hash_get(join('.', 'unique', $unique_field), $body{$unique_field}); 48 | return {error => {text => 'User already exists', code => 400 } } if $value; 49 | $unique_values{$unique_field} = $body{$unique_field}; 50 | 51 | } 52 | $log->debugf('Unique values %s', \%unique_values); 53 | 54 | # Need to add more validation 55 | my %cleaned_body; 56 | @cleaned_body{keys $fields->%*} = @body{keys $fields->%*}; 57 | 58 | my $id = await $self->next_id; 59 | 60 | await $storage->hash_set('machine', $id, encode_json_utf8(\%cleaned_body)); 61 | await fmap_void( 62 | async sub { 63 | my $key = shift; 64 | await $storage->hash_set(join('.', 'unique', $key), $unique_values{$key}, 1); 65 | }, foreach => [keys %unique_values], concurrent => 4 66 | ); 67 | $log->infof('added new machine with id: %d', $id); 68 | my $machine = {id => $id, record => \%cleaned_body}; 69 | $new_machine_handler->emit($machine); 70 | return $machine; 71 | } else { 72 | return {error => {text => 'Wrong request METHOD please use PUT for this resource', code => 400 } }; 73 | } 74 | } 75 | 76 | async method new_machine : Emitter() ($source){ 77 | $new_machine_handler->each(sub { 78 | my $machine = shift; 79 | $source->emit($machine); 80 | }); 81 | } 82 | 83 | 1; 84 | -------------------------------------------------------------------------------- /example/lib/Coffee/Manager/Stats.pm: -------------------------------------------------------------------------------- 1 | package Coffee::Manager::Stats; 2 | 3 | use Myriad::Service; 4 | 5 | async method startup () { 6 | 7 | } 8 | 9 | async method new_user : Receiver(service => 'coffee.manager.user', channel => 'new_user') ($sink) { 10 | return $sink->map(sub { 11 | my $user = shift; 12 | $log->warnf('GOT new_user %s', $user); 13 | # Storage ZADD new_user epoch $user 14 | 15 | }); 16 | } 17 | 18 | async method new_machine : Receiver(service => 'coffee.manager.machine', channel => 'new_machine') ($sink) { 19 | return $sink->map(sub { 20 | my $machine = shift; 21 | $log->warnf('GOT new_machine %s', $machine); 22 | # Storage ZADD new_machine epoch $machine 23 | 24 | }); 25 | } 26 | 27 | async method new_coffee : Receiver(service => 'coffee.manager.coffee', channel => 'new_coffee') ($sink) { 28 | return $sink->map(sub { 29 | my $coffee = shift; 30 | $log->warnf('GOT new_coffee %s', $coffee); 31 | # Storage ZADD new_coffee epoch $coffee 32 | # Storage ZADD user_$userid_coffee epoch $coffee 33 | # Storage ZADD machine_$machid_coffee epoch $coffee 34 | 35 | }); 36 | } 37 | 38 | async method stats : RPC (%args) { 39 | my $for = $args{for} // 'all'; 40 | my $result; 41 | if ( $for eq 'user' or $for eq 'all' ) { 42 | # Total users 43 | # users per hour 44 | # Top Coffee drinkers 45 | # highest caffeine level for users 46 | } 47 | 48 | if ( $for eq 'machine' or $for eq 'all' ) { 49 | # Total Machines 50 | # Machines per hour 51 | # Top machine sellers 52 | } 53 | 54 | if ( $for eq 'coffee' or $for eq 'all' ) { 55 | # Total coffee 56 | # Coffee's per hour 57 | } 58 | 59 | return $result; 60 | } 61 | 62 | async method user_stats : RPC (%args) { 63 | my $user_id = $args{user_id}; 64 | 65 | # user stats 66 | # per hour and overall 67 | } 68 | 69 | async method machine_stats : RPC (%args) { 70 | my $machine_id = $args{machine_id}; 71 | 72 | # user stats 73 | # per hour and overall 74 | } 75 | 1; 76 | -------------------------------------------------------------------------------- /example/lib/Coffee/Manager/User.pm: -------------------------------------------------------------------------------- 1 | package Coffee::Manager::User; 2 | 3 | use Myriad::Service; 4 | 5 | use JSON::MaybeUTF8 qw(:v1); 6 | use Ryu::Source; 7 | 8 | field $fields; 9 | field $last_id; 10 | field $new_user_handler = Ryu::Source->new; 11 | 12 | BUILD (%args) { 13 | $fields = { 14 | login => { 15 | mandatory => 1, 16 | unique => 1, 17 | }, 18 | password => { 19 | mandatory => 1, 20 | hashed => 1, # add support for hashing 21 | }, 22 | email => { 23 | mandatory => 1, 24 | unique => 1, 25 | }, 26 | }; 27 | } 28 | 29 | async method startup () { 30 | $last_id = await $api->storage->get('id'); 31 | } 32 | 33 | async method next_id () { 34 | my $id = await $api->storage->incr('id'); 35 | $last_id = $id; 36 | return $id; 37 | } 38 | 39 | async method request : RPC (%args) { 40 | $log->debugf('GOT USER Request: %s', \%args); 41 | 42 | my $storage = $api->storage; 43 | # Only accept PUT request 44 | if ( $args{type} eq 'PUT' or $args{type} eq 'POST' ) { 45 | my %body = $args{body}->%*; 46 | return {error => {text => 'Missing Argument. Must supply login, password, email', code => 400 } } 47 | if grep { ! exists $body{$_} } keys $fields->%*; 48 | 49 | my %unique_values; 50 | # should be converted to fmap instead of for 51 | for my $unique_field (grep { exists $fields->{$_}{unique}} keys $fields->%*) { 52 | my $value = await $storage->hash_get(join('.', 'unique', $unique_field), $body{$unique_field}); 53 | return {error => {text => 'User already exists', code => 400 } } if $value; 54 | $unique_values{$unique_field} = $body{$unique_field}; 55 | 56 | } 57 | $log->warnf('Unique values %s', \%unique_values); 58 | 59 | # Need to add more validation 60 | my %cleaned_body; 61 | @cleaned_body{keys $fields->%*} = @body{keys $fields->%*}; 62 | 63 | my $id = await $self->next_id; 64 | $log->debugf('ID after INCR: %d', $id); 65 | 66 | await $storage->hash_set('user', $id, encode_json_utf8(\%cleaned_body)); 67 | await fmap_void( 68 | async sub { 69 | my $key = shift; 70 | await $storage->hash_set(join('.', 'unique', $key), $unique_values{$key}, 1); 71 | }, foreach => [keys %unique_values], concurrent => 4 72 | ); 73 | $log->infof('added new user with id: %d', $id); 74 | my $user = {id => $id, record => \%cleaned_body}; 75 | $new_user_handler->emit($user); 76 | return $user; 77 | } else { 78 | return {error => {text => 'Wrong request METHOD please use PUT for this resource', code => 400 } }; 79 | } 80 | } 81 | 82 | async method new_user : Emitter() ($source){ 83 | $new_user_handler->each(sub { 84 | my $user = shift; 85 | $source->emit($user); 86 | }); 87 | } 88 | 89 | 1; 90 | -------------------------------------------------------------------------------- /example/lib/Coffee/Server/REST.pm: -------------------------------------------------------------------------------- 1 | package Coffee::Server::REST; 2 | 3 | use Object::Pad; 4 | 5 | class Coffee::Server::REST extends IO::Async::Notifier; 6 | 7 | 8 | use Future::AsyncAwait; 9 | use Syntax::Keyword::Try; 10 | use Net::Async::HTTP::Server; 11 | use HTTP::Response; 12 | use JSON::MaybeUTF8 qw(:v1); 13 | use Unicode::UTF8; 14 | use Scalar::Util qw(refaddr blessed); 15 | use curry; 16 | 17 | use Log::Any qw($log); 18 | 19 | =head1 NAME 20 | 21 | Coffee Manager REST API Service 22 | 23 | =head1 DESCRIPTION 24 | 25 | Provides an HTTP interface to Coffee Manager. 26 | 27 | =cut 28 | 29 | field $server; 30 | field $listen_port; 31 | field $active_requests; 32 | field $requests_sink; 33 | 34 | method configure (%args) { 35 | 36 | $listen_port = delete $args{listen_port} if exists $args{listen_port}; 37 | $active_requests = {}; 38 | 39 | return $self->next::method(%args); 40 | } 41 | 42 | 43 | method _add_to_loop ($loop) { 44 | # server for incoming requests 45 | $self->add_child( 46 | $server = Net::Async::HTTP::Server->new( 47 | on_request => $self->$curry::weak( method ($http, $req) { 48 | # Keep request in memory until we respond to it. 49 | my $k = refaddr($req); 50 | $active_requests->{$k} = $self->handle_http_request($req)->on_ready( 51 | $self->$curry::weak( method ($f) { 52 | delete $active_requests->{$k}; 53 | }) 54 | ); 55 | }), 56 | ) 57 | ); 58 | } 59 | 60 | 61 | async method handle_http_request ($req) { 62 | $log->debugf('HTTP receives %s %s:%s', $req->method, $req->path, $req->body); 63 | try { 64 | # Capture only alphabetical names as path, and numerics as parameters. 65 | my ($service, @path) = ($req->path =~ /\/([A-Za-z]+)/g); 66 | 67 | # add default method, if no method supplied. 68 | push @path, 'request' unless @path; 69 | # Construct method name from path 70 | my $method = join('_', @path); 71 | 72 | my %params = ($req->path =~ /\/([0-9]+)/g); 73 | # If no params are passed on requirement structure 74 | # Check if params passed as query params. 75 | if (!%params) { 76 | %params = $req->query_form; 77 | } 78 | my $body_params = decode_json_utf8($req->body || '{}'); 79 | 80 | $log->tracef('Had body_params %s | params %s | for service %s, method: %s | path: %s', $body_params, \%params, $service, $method, \@path); 81 | 82 | $requests_sink->emit({request => $req, service => $service, method => $method, params => \%params, body => $body_params, type => $req->method}); 83 | } catch ($e) { 84 | $log->errorf('Failed with handling request - %s', $e); 85 | $self->reply_fail($req, $e); 86 | } 87 | } 88 | 89 | method reply_success ($req, $data) { 90 | my $response = HTTP::Response->new(200); 91 | 92 | $response->add_content(encode_json_utf8($data)); 93 | $response->content_type("application/json"); 94 | $response->content_length(length $response->content); 95 | 96 | $req->respond($response); 97 | } 98 | 99 | method reply_fail ($req, $error) { 100 | 101 | my $content = {error_code => '400', error_text => ''}; 102 | $content->{error_text} = $error; 103 | 104 | my $response = HTTP::Response->new($content->{error_code}); 105 | $response->add_content(encode_json_utf8($content)); 106 | $response->content_type("application/json"); 107 | $response->content_length(length $response->content); 108 | 109 | $req->respond($response); 110 | } 111 | 112 | async method start ($sink) { 113 | 114 | $requests_sink = $sink; 115 | my $listner = await $server->listen( 116 | addr => { 117 | family => 'inet', 118 | socktype => 'stream', 119 | port => $listen_port}); 120 | my $port = $listner->read_handle->sockport; 121 | 122 | $log->debugf('HTTP REST API service is listening on port %s', $port); 123 | return $port; 124 | } 125 | 126 | 1; 127 | -------------------------------------------------------------------------------- /example/lib/Example/Service/Factor.pm: -------------------------------------------------------------------------------- 1 | package Example::Service::Factor; 2 | 3 | use Myriad::Service; 4 | 5 | field $factor = 0; 6 | field $players_id; 7 | 8 | async method diagnostics ($level) { 9 | return 'ok'; 10 | } 11 | 12 | async method secret_checks : Receiver(service => 'example.service.secret') ($sink) { 13 | $players_id ||= {}; 14 | return $sink->map( 15 | async sub { 16 | my $e = shift; 17 | my %info = ($e->@*); 18 | $log->tracef('INFO %s', \%info); 19 | my $data = $info{'data'}; 20 | my $secret_service = $api->service_by_name('example.service.secret'); 21 | my $secret_storage = $secret_service->storage; 22 | 23 | # If pass reset the game, with new value. 24 | if($data->{pass}) { 25 | $factor = 0; 26 | $players_id = {}; 27 | await $secret_service->call_rpc('reset_game', secret => int(rand(100))); 28 | $log->info('Called RESET'); 29 | } else { 30 | # We will: 31 | # Double the factor on every new player joining 32 | # increment factor by number of player trials on every check. 33 | my $player_id = $data->{id}; 34 | my $trials = await $secret_storage->hash_get('current_players',$player_id); 35 | 36 | # since there is no hash_count implemented yet. 37 | $players_id->{$player_id} = 1; 38 | 39 | $log->tracef('TRIALS: %s, MILT: %s', $trials, scalar keys %$players_id); 40 | $factor += $trials; 41 | $factor *= 2 for keys %$players_id; 42 | 43 | } 44 | $log->infof('Setting factor %d', $factor); 45 | await $api->storage->set('factor', $factor); 46 | } 47 | )->resolve; 48 | } 49 | 50 | 1; 51 | 52 | 53 | -------------------------------------------------------------------------------- /example/lib/Example/Service/Secret.pm: -------------------------------------------------------------------------------- 1 | package Example::Service::Secret; 2 | 3 | use Myriad::Service; 4 | use Ryu::Source; 5 | use Future::Utils qw( fmap_void ); 6 | 7 | field $secret = $ENV{'SECRET'}; 8 | field $check_event_handler = Ryu::Source->new; 9 | 10 | # temporarily until we add more operations to storage. 11 | field $ids = {}; 12 | 13 | async method diagnostics ($level) { 14 | return 'ok'; 15 | } 16 | 17 | async method check : RPC (%args) { 18 | my ($id, $value) = map { $args{$_} } qw(id value); 19 | $ids->{$id} = 1; 20 | # If it was not set by ENV 21 | $secret = int(rand(100)) unless $secret; 22 | 23 | # Get Factor of difference that will be allowed. 24 | my $factor_storage = $api->service_by_name('example.service.factor')->storage; 25 | my $factor = await $factor_storage->get('factor'); 26 | $factor = 0 unless $factor; 27 | 28 | # Get player previous trials info 29 | my $storage = $api->storage; 30 | my $trials = await $storage->hash_get('current_players', $id); 31 | $trials = 0 unless $trials; 32 | 33 | $log->debugf('Received check call. ID: %d | Value: %d | Secret: %d | Factor: %d', $id, $value, $secret, $factor); 34 | my $res = {answer => 'Wrong', factor => $factor, hint => '', id => $id, value => $value, trials => ++$trials}; 35 | 36 | # Check if player guessed the secret; allowing a margin of difference(factor) 37 | my $diff = $value - $secret; 38 | if (abs($diff) <= $factor) { 39 | $res->{answer} = 'Correct'; 40 | } elsif ($diff < 0 ) { 41 | $res->{hint} = 'guess higher'; 42 | } else { 43 | $res->{hint} = 'guess lower'; 44 | } 45 | 46 | # Update player trials. 47 | await $storage->hash_set('current_players', $id, $trials); 48 | $check_event_handler->emit($res); 49 | return $res; 50 | 51 | } 52 | 53 | async method reset_game : RPC (%args) { 54 | # Storage not yet impleminting DEL or HGETALL hence 55 | my $res = await fmap_void( async sub { 56 | my $id = shift; 57 | await $api->storage->hash_set('current_players', $id, 0); 58 | }, foreach => [keys $ids->%*], concurrent => 10); 59 | $secret = $args{'secret'}; 60 | 61 | return {reset_done => 1} unless defined $res; 62 | } 63 | 64 | async method secret_checks : Emitter() ($source){ 65 | $check_event_handler->each(sub { 66 | my $res = shift; 67 | my $pass = $res->{answer} eq 'Correct' ? 1 : 0; 68 | my $event = {pass => $pass, id => $res->{id}}; 69 | $source->emit($event); 70 | }); 71 | } 72 | 73 | 1; 74 | -------------------------------------------------------------------------------- /example/logic-demo.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | use Myriad; 6 | 7 | { 8 | package Example::Service::Trigger; 9 | 10 | # Simple service, has a value that sends an event on every update to it. 11 | 12 | use Myriad::Service; 13 | use Ryu::Source; 14 | 15 | field $count = 0; 16 | field $value; 17 | field $call_event_handler = Ryu::Source->new; 18 | 19 | async method current : RPC { 20 | return { value => $value, count => $count}; 21 | } 22 | 23 | async method update : RPC (%args) { 24 | 25 | $value = $args{new_value}; 26 | $count = 0 if $args{reset}; 27 | $call_event_handler->emit(1); 28 | return await $self->current; 29 | 30 | } 31 | 32 | 33 | async method value_updated : Emitter() ($sink, $api, %args){ 34 | $call_event_handler->each(sub { 35 | my $emit = shift; 36 | my $e = {name => "EMITTER-Trigger service", value => $value, count => ++$count}; 37 | $sink->emit($e) if $emit; 38 | }); 39 | } 40 | 41 | } 42 | 43 | 44 | { 45 | package Example::Service::Holder; 46 | 47 | # Simple service, react on a received event by keeping the sum of its emitted values. 48 | 49 | use Myriad::Service; 50 | use JSON::MaybeUTF8 qw(:v1); 51 | 52 | field $sum = 0; 53 | field $count = 0; 54 | 55 | async method value_updated :Receiver(service => 'example.service.trigger') ($sink, $api, %args) { 56 | $log->warnf('Receiver Called | %s | %s | %s'); 57 | 58 | while(1) { 59 | await $sink->map( 60 | sub { 61 | my $e = shift; 62 | my %info = ($e->@*); 63 | $log->tracef('INFO %s', \%info); 64 | 65 | my $data = decode_json_utf8($info{'data'}); 66 | if ( ++$count == $data->{count} ){ 67 | $sum += $data->{value}; 68 | } else { 69 | $sum = $data->{value}; 70 | $count = $data->{count}; 71 | } 72 | })->completed; 73 | } 74 | 75 | } 76 | 77 | async method current_sum : RPC { 78 | return { sum => $sum, count => $count}; 79 | } 80 | 81 | 82 | } 83 | 84 | no indirect; 85 | 86 | use Syntax::Keyword::Try; 87 | use Future::AsyncAwait; 88 | use Log::Any qw($log); 89 | use Test::More; 90 | 91 | (async sub { 92 | my $myriad = Myriad->new; 93 | 94 | my @arg = ("-l","debug","--redis_uri","redis://redis6:6379","Example::Service::Trigger,Example::Service::Holder"); 95 | $myriad->configure_from_argv(@arg)->get; 96 | $log->warnf('done configuring'); 97 | $myriad->run; 98 | 99 | })->()->get; 100 | 101 | done_testing(); 102 | -------------------------------------------------------------------------------- /example/rpc-demo.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | use Myriad; 6 | 7 | { 8 | package Example::Service::RPC; 9 | 10 | # Simple RPC method example. 11 | 12 | use microservice; 13 | 14 | field $count = 0; 15 | 16 | async method current :RPC { 17 | return $count++; 18 | } 19 | 20 | } 21 | 22 | no indirect; 23 | 24 | use Syntax::Keyword::Try; 25 | use Future::AsyncAwait; 26 | use Log::Any qw($log); 27 | use Log::Any::Adapter qw(Stdout), log_level => 'info'; 28 | use Net::Async::Redis; 29 | use IO::Async::Loop; 30 | 31 | use Test::More; 32 | 33 | my $loop = IO::Async::Loop->new(); 34 | 35 | $loop->add(my $send = Net::Async::Redis->new()); 36 | $loop->add(my $receive = Net::Async::Redis->new()); 37 | 38 | (async sub { 39 | my $myriad = Myriad->new; 40 | $myriad->add_service( 41 | 'Example::Service::RPC' 42 | ); 43 | { 44 | # TODO: This should be through service life cycle 45 | my $sub = await $receive->subscribe("client"); 46 | my $f = $sub->events->map('payload')->decode('json')->map(sub { 47 | use Data::Dumper; 48 | warn Dumper(shift->{response}); 49 | }); 50 | 51 | for my $i (0 .. 100) { 52 | await $send->xadd("Example::Service::RPC", '*', rpc => "current", args => '{}', who => 'client', deadline => time + 1000, stash => '{}'); 53 | } 54 | 55 | await $f->completed; 56 | } 57 | })->()->get; 58 | 59 | done_testing(); 60 | -------------------------------------------------------------------------------- /example/use-config.pl: -------------------------------------------------------------------------------- 1 | package Serivce::Example::Config; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Myriad::Service; 7 | 8 | config 'required_key'; 9 | config 'optional_key', default => 'option'; 10 | config 'secret', secure => 1; 11 | 12 | async method startup () { 13 | 14 | # if required key was not found in one of the sources 15 | # this sub will never run 16 | 17 | # access config through API 18 | # value because all config are Ryu::Observable 19 | my $secret = $api->config('secret')->value->secret_value; 20 | my $optional = $api->config('optional_key')->as_string; 21 | 22 | # This will throw 23 | my $unknown = $api->config('unknown'); 24 | } 25 | 26 | 1; 27 | -------------------------------------------------------------------------------- /example/writing-test.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Future::AsyncAwait; 5 | 6 | use Test::More; 7 | use Test::Myriad; 8 | 9 | my ($mocked_service, $developer_service); 10 | 11 | package Test::Service::Real { 12 | use Myriad::Service; 13 | use Test::More; 14 | 15 | async method say_hi : RPC { 16 | return {mocked => 0}; 17 | } 18 | 19 | async method say_bye : RPC { 20 | return {bye => 1}; 21 | } 22 | 23 | async method get_event : Receiver(service => 'Test::Service::Mocked', channel => 'weekends') ($source) { 24 | await $source->each(sub { 25 | my $event = shift; 26 | like($event->{name}, qr{Saturday|Sunday},'We are getting data correctly'); 27 | })->completed(); 28 | } 29 | } 30 | 31 | BEGIN { 32 | $mocked_service = Test::Myriad->add_service(name => "Test::Service::Mocked") 33 | ->add_rpc('say_hi', hello => 'other service!') 34 | ->add_subscription('weekends', array => [{ name => 'Saturday' }, {name => 'Sunday' }]); 35 | 36 | $developer_service = Test::Myriad->add_service(service => 'Test::Service::Real'); 37 | } 38 | 39 | await Test::Myriad->ready; 40 | 41 | subtest 'it should respond to RPC' => sub { 42 | (async sub { 43 | my $response = await $mocked_service->call_rpc('say_hi'); 44 | ok($response->{response}->{hello}, 'rpc message has been received'); 45 | })->()->get(); 46 | }; 47 | 48 | subtest 'it can mock developer rpc' => sub { 49 | (async sub { 50 | $developer_service->mock_rpc('say_hi', mocked => 1); 51 | my $response = await $developer_service->call_rpc('say_hi'); 52 | ok($response->{response}->{mocked}, 'it can mock rpc provided by other services'); 53 | })->()->get(); 54 | }; 55 | 56 | done_testing(); 57 | 58 | -------------------------------------------------------------------------------- /lib/Myriad/API.pm: -------------------------------------------------------------------------------- 1 | package Myriad::API; 2 | 3 | use Myriad::Class; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::API - provides an API for Myriad services 13 | 14 | =head1 SYNOPSIS 15 | 16 | =head1 DESCRIPTION 17 | 18 | Used internally within L services for providing access to 19 | storage, subscription and RPC behaviour. 20 | 21 | =cut 22 | 23 | use List::UtilsBy qw(extract_by); 24 | use Myriad::Config; 25 | use Myriad::Mutex; 26 | use Myriad::Service::Remote; 27 | use Myriad::Service::Storage; 28 | use Myriad::Service::Bus; 29 | 30 | =head1 METHODS - Accessors 31 | 32 | =cut 33 | 34 | field $myriad; 35 | field $service; 36 | 37 | =head2 service_name 38 | 39 | Returns the name of this service (as a plain string). 40 | 41 | =cut 42 | 43 | field $service_name : reader; 44 | 45 | =head2 storage 46 | 47 | Returns a L-compatible instance for interacting with storage. 48 | 49 | =cut 50 | 51 | field $storage : reader; 52 | field $config; 53 | field $bus; 54 | 55 | =head1 METHODS - Other 56 | 57 | =cut 58 | 59 | BUILD (%args) { 60 | weaken($myriad = delete $args{myriad}); 61 | weaken($service = delete $args{service}); 62 | $service_name = delete $args{service_name} // die 'need a service name'; 63 | $config = delete $args{config} // {}; 64 | $storage = Myriad::Service::Storage->new( 65 | prefix => $service_name, 66 | storage => $myriad->storage 67 | ); 68 | } 69 | 70 | =head2 service_by_name 71 | 72 | Returns a service proxy instance for the given service name. 73 | 74 | This can be used to call RPC methods and act on subscriptions. 75 | 76 | =cut 77 | 78 | method service_by_name ($name) { 79 | return Myriad::Service::Remote->new( 80 | myriad => $myriad, 81 | service_name => $myriad->registry->make_service_name($name), 82 | local_service_name => $service_name 83 | ); 84 | } 85 | 86 | 87 | =head2 config 88 | 89 | Returns a L that holds the value of the given 90 | configuration key. 91 | 92 | =cut 93 | 94 | method config ($key) { 95 | my $pkg = caller; 96 | if($Myriad::Config::SERVICES_CONFIG{$pkg}->{$key}) { 97 | return $config->{$key}; 98 | } 99 | Myriad::Exception::Config::UnregisteredConfig->throw( 100 | reason => "$key is not registered by service $service_name" 101 | ); 102 | } 103 | 104 | =head2 mutex 105 | 106 | =cut 107 | 108 | async method mutex (@args) { 109 | my ($code) = extract_by { ref($_) eq 'CODE' } @args; 110 | # `name` is used for a shared mutex across services 111 | my $name = @args % 2 ? shift(@args) : $service_name; 112 | my %args = @args; 113 | # `key` is used for a suffix for a specific service 114 | my $suffix = delete($args{key}) // ''; 115 | my $mutex = Myriad::Mutex->new( 116 | %args, 117 | loop => $service->loop, 118 | key => $name . (length($suffix) ? "[$suffix]" : ''), 119 | storage => $storage, 120 | id => $service->uuid, 121 | ); 122 | if($code) { 123 | try { 124 | await $mutex->acquire; 125 | my $f = $code->(); 126 | await $f if blessed($f) and $f->isa('Future'); 127 | await $mutex->release; 128 | } catch($e) { 129 | $log->errorf('Failed while processing mutex-protected code: %s', $e); 130 | await $mutex->release; 131 | die $e; 132 | } 133 | return undef; 134 | } else { 135 | return await $mutex->acquire; 136 | } 137 | } 138 | 139 | method bus { 140 | unless($bus) { 141 | $bus = Myriad::Service::Bus->new( 142 | service => $service_name, 143 | myriad => $myriad, 144 | ); 145 | $bus->setup->retain; 146 | } 147 | return $bus; 148 | } 149 | 150 | 1; 151 | 152 | __END__ 153 | 154 | =head1 AUTHOR 155 | 156 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 157 | 158 | See L for full details. 159 | 160 | =head1 LICENSE 161 | 162 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 163 | 164 | -------------------------------------------------------------------------------- /lib/Myriad/Example/Call.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Example::Call; 2 | # VERSION 3 | # To try this out, run: 4 | # myriad.pl service Myriad::Example::Call rpc myriad.example.call/remote_call 5 | use Myriad::Service ':v1'; 6 | async method remote_call : RPC (%args) { 7 | my $srv = await $api->service_by_name('myriad.example.call'); 8 | return await $srv->target_method; 9 | } 10 | async method target_method : RPC { 11 | return 'This is a method we call from within another service'; 12 | } 13 | 1; 14 | -------------------------------------------------------------------------------- /lib/Myriad/Example/Echo.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Example::Echo; 2 | # VERSION 3 | # To try this out, run: 4 | # myriad.pl service Myriad::Example::RPC rpc myriad.example.echo/message='{"message":"example message"}' 5 | use Myriad::Service ':v1'; 6 | async method echo : RPC (%args) { 7 | return $args{message}; 8 | } 9 | 1; 10 | -------------------------------------------------------------------------------- /lib/Myriad/Example/RPC.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Example::RPC; 2 | # VERSION 3 | # To try this out, run: 4 | # myriad.pl service Myriad::Example::RPC rpc myriad.example.rpc 5 | use Myriad::Service ':v1'; 6 | async method message : RPC { 7 | return 'Welcome to Myriad'; 8 | } 9 | 1; 10 | -------------------------------------------------------------------------------- /lib/Myriad/Example/Startup.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Example::Startup; 2 | # VERSION 3 | # To try this out, run: 4 | # myriad.pl service Myriad::Example::Startup 5 | use Myriad::Service ':v1'; 6 | async method startup (%args) { 7 | $log->infof('This is our example service, running code in the startup method'); 8 | } 9 | 1; 10 | -------------------------------------------------------------------------------- /lib/Myriad/Exception.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Exception; 2 | 3 | use Myriad::Class type => 'role'; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Exception - standard exception rôle for all L code 13 | 14 | =head1 DESCRIPTION 15 | 16 | This is a rôle used for all exceptions throughout the framework. 17 | 18 | =cut 19 | 20 | method category; 21 | method message; 22 | 23 | =head2 throw 24 | 25 | Instantiates a new exception and throws it (by calling L). 26 | 27 | =cut 28 | 29 | sub throw ($class, @args) { 30 | my $self = blessed($class) ? $class : $class->new(@args); 31 | die $self; 32 | } 33 | 34 | 1; 35 | 36 | =head1 AUTHOR 37 | 38 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 39 | 40 | See L for full details. 41 | 42 | =head1 LICENSE 43 | 44 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 45 | 46 | -------------------------------------------------------------------------------- /lib/Myriad/Exception/Base.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Exception::Base; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | use utf8; 10 | 11 | =encoding utf8 12 | 13 | =head1 NAME 14 | 15 | Myriad::Exception::Base - common class for all exceptions 16 | 17 | =head1 DESCRIPTION 18 | 19 | See L for the rôle which defines the exception API. 20 | 21 | =cut 22 | 23 | no indirect qw(fatal); 24 | use Myriad::Exception; 25 | 26 | use overload '""' => sub { shift->as_string }, bool => sub { 1 }, fallback => 1; 27 | 28 | sub new { 29 | my ($class, %args) = @_; 30 | bless \%args, $class 31 | } 32 | 33 | =head2 reason 34 | 35 | The failure reason. Freeform text. 36 | 37 | =cut 38 | 39 | sub reason { shift->{reason} } 40 | 41 | =head2 as_string 42 | 43 | Returns the exception message as a string. 44 | 45 | =cut 46 | 47 | sub as_string { shift->message } 48 | 49 | 1; 50 | 51 | =head1 AUTHOR 52 | 53 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 54 | 55 | See L for full details. 56 | 57 | =head1 LICENSE 58 | 59 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 60 | 61 | -------------------------------------------------------------------------------- /lib/Myriad/Exception/Builder.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Exception::Builder; 2 | 3 | use Myriad::Class class => ''; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Exception::Builder - applies L to an exception class 13 | 14 | =head1 DESCRIPTION 15 | 16 | See L for the rôle that defines the exception API. 17 | 18 | =cut 19 | 20 | # We deliberately *don't* want class/method keywords, but *do* want MOP 21 | use Object::Pad qw(:experimental(mop)); 22 | 23 | use Myriad::Exception; 24 | use Myriad::Exception::Base; 25 | 26 | use constant CLASS_CREATION_METHOD => Object::Pad::MOP::Class->can('create_class') || Object::Pad::MOP::Class->can('begin_class'); 27 | 28 | # Not currently used, but nice as a hint 29 | our @EXPORT = our @EXPORT_OK = qw(declare_exception); 30 | 31 | # When importing, you can set the default category to avoid some 32 | # repetition when there's a long list of exceptions to be defining 33 | our %DEFAULT_CATEGORY_FOR_CLASS; 34 | 35 | our %EXCEPTIONS; 36 | 37 | sub import { 38 | my ($class, %args) = @_; 39 | my $pkg = caller; 40 | no strict 'refs'; 41 | $DEFAULT_CATEGORY_FOR_CLASS{$pkg} = delete $args{category} if exists $args{category}; 42 | die 'unexpected parameters: ' . join ',', sort keys %args if %args; 43 | *{$pkg . '::declare_exception'} = $class->can('declare_exception'); 44 | } 45 | 46 | =head2 declare_exception 47 | 48 | Creates a new exception under the L namespace. 49 | 50 | This will be a class formed from the caller's class: 51 | 52 | =over 4 53 | 54 | =item * called from C, would strip the C prefix 55 | 56 | =item * any other class will remain intact 57 | 58 | =back 59 | 60 | e.g. L when calling this would end up with classes under L, 61 | but C would get L 62 | as the exception base class. 63 | 64 | Takes the following parameters: 65 | 66 | =over 4 67 | 68 | =item * C<$name> - the exception 69 | 70 | =item * C<%args> - extra details 71 | 72 | =back 73 | 74 | Details can currently include: 75 | 76 | =over 4 77 | 78 | =item * C 79 | 80 | =item * C 81 | 82 | =back 83 | 84 | Returns the generated classname. 85 | 86 | =cut 87 | 88 | sub declare_exception { 89 | my ($name, %args) = @_; 90 | my $caller = caller; 91 | my $pkg = length($name) ? (join '::', ( 92 | delete($args{package}) || ('Myriad::Exception::' . (caller =~ s{^Myriad::}{}r)) 93 | ), $name) : $caller; 94 | my $category = delete $args{category} // $DEFAULT_CATEGORY_FOR_CLASS{$caller}; 95 | die 'invalid category ' . $category unless $category =~ /^[0-9a-z_]+$/; 96 | my $message = delete $args{message} // 'unknown'; 97 | 98 | die 'already have exception ' . $pkg if exists $EXCEPTIONS{$pkg}; 99 | 100 | $EXCEPTIONS{$pkg} //= create_exception({ 101 | package => $pkg, 102 | category => $category, 103 | message => $message 104 | }); 105 | return $pkg; 106 | } 107 | 108 | sub create_exception ($details) { 109 | my $pkg = delete $details->{package} or die 'no package'; 110 | my $category = delete $details->{category} or die 'no category'; 111 | my $message = delete $details->{message} or die 'no message'; 112 | 113 | try { 114 | Myriad::Class->import( 115 | target => $pkg, 116 | class => '', 117 | ); 118 | $EXCEPTIONS{$pkg} = my $class = (CLASS_CREATION_METHOD)->( 119 | 'Object::Pad::MOP::Class', 120 | $pkg, 121 | extends => 'Myriad::Exception::Base', 122 | ); 123 | $class->add_role('Myriad::Exception'); 124 | $class->add_method( 125 | category => sub ($self) { $category } 126 | ); 127 | $class->add_method( 128 | message => sub ($self) { 129 | my $str = $message . ' (category=' . $self->category; 130 | if($self->reason) { 131 | $str .= ' , reason=' . $self->reason; 132 | } 133 | return $str . ')'; 134 | } 135 | ); 136 | { # Until we get class methods in role { } blocks, need to inject this directly 137 | no strict 'refs'; 138 | *{$pkg . '::throw'} = sub ($class, @args) { 139 | my $self = blessed($class) ? $class : $class->new(@args); 140 | die $self; 141 | }; 142 | } 143 | $class->seal; 144 | return $class; 145 | } catch ($e) { 146 | $log->errorf('Failed to raise declare exception - %s', $e); 147 | } 148 | } 149 | 150 | 1; 151 | 152 | =head1 AUTHOR 153 | 154 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 155 | 156 | See L for full details. 157 | 158 | =head1 LICENSE 159 | 160 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 161 | 162 | -------------------------------------------------------------------------------- /lib/Myriad/Exception/General.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Exception::General; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | use utf8; 10 | 11 | =encoding utf8 12 | 13 | =head1 NAME 14 | 15 | Myriad::Exception::Base - common class for all exceptions 16 | 17 | =head1 DESCRIPTION 18 | 19 | See L for the rôle that defines the exception API. 20 | 21 | =cut 22 | 23 | no indirect qw(fatal); 24 | 25 | use Myriad::Exception::Builder; 26 | 27 | sub category { 'myriad' } 28 | 29 | sub message { shift->{message} //= 'unknown exception' } 30 | 31 | 1; 32 | 33 | =head1 AUTHOR 34 | 35 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 36 | 37 | See L for full details. 38 | 39 | =head1 LICENSE 40 | 41 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 42 | 43 | -------------------------------------------------------------------------------- /lib/Myriad/Exception/InternalError.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Exception::InternalError; 2 | 3 | use Myriad::Exception::Builder; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Exception::InternalError - common exception when the error is not relevant to the client. 13 | 14 | =head1 DESCRIPTION 15 | 16 | See L for the rôle that defines the exception API. 17 | 18 | =cut 19 | 20 | declare_exception '' => ( 21 | category => 'internal', 22 | message => 'Internal error' 23 | ); 24 | 25 | 1; 26 | 27 | =head1 AUTHOR 28 | 29 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 30 | 31 | See L for full details. 32 | 33 | =head1 LICENSE 34 | 35 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 36 | 37 | -------------------------------------------------------------------------------- /lib/Myriad/Guide/Tutorial.pod: -------------------------------------------------------------------------------- 1 | =encoding utf8 2 | 3 | =head1 NAME 4 | 5 | Myriad::Guide::Tutorial - introduction and tutorial for the L framework 6 | 7 | =head1 TUTORIAL 8 | 9 | Most of the time, you would use the L script to run everything. 10 | 11 | The L framework handles loading, logging, configuration and other tasks: you provide 12 | services which implement functionality, and wire them together. Instead of implementing top-level code, 13 | those services can call each other or subscribe to data streams. 14 | 15 | Note that if you're on Windows, you may need to run the C commands under PowerShell or WSL 16 | terminal, due to the nested quotes. 17 | 18 | =head2 Run code on startup 19 | 20 | Each service has a C method - this is where you put code that should run once the service is 21 | loaded and ready. 22 | 23 | # EXAMPLE: lib/Myriad/Example/Startup.pm 24 | 25 | There are 3 key lines here - firstly, we give our service a name: 26 | 27 | package Myriad::Example::Startup 28 | 29 | Every service has a unique name, and we can have multiple instances of a given service (for example, connecting to different database shards or serving different domain names for a webhook). 30 | 31 | Next, we load the framework and indicate that this is a service: 32 | 33 | use Myriad::Service ':v1'; 34 | 35 | This line applies C, C, and many other "standard" settings - see L for more details. 36 | 37 | Next, we provide methods - in this case, a C method: 38 | 39 | async method startup (%args) { 40 | 41 | We're using L for the C keyword - every service is a Perl OO class, and L is the prototype for the planned Perl core OO implementation. 42 | The C keyword comes from L - it allows us to use the C keyword if there are any asynchronous operations that should complete before 43 | we return. 44 | 45 | =head2 An RPC call 46 | 47 | "Remote procedure calls", usually abbreviated RPC, are the basic building blocks for services. Creating a method marked as C tells Myriad that this method should be available for other services to call. 48 | 49 | # EXAMPLE: lib/Myriad/Example/RPC.pm 50 | 51 | We use L to mark a method as an RPC call. 52 | 53 | =head2 Simple RPC echo method 54 | 55 | This service takes parameters, in this case returning them as the result from the RPC call: 56 | 57 | # EXAMPLE: lib/Myriad/Example/Echo.pm 58 | 59 | We're using Perl core signatures for the parameters, although you can use C<@_> as usual if you prefer: 60 | 61 | async method echo : RPC { 62 | my (%args) = @_; 63 | return $args{message}; 64 | } 65 | 66 | =head2 Call another service 67 | 68 | This service takes parameters, in this case returning them as the result from the RPC call: 69 | 70 | # EXAMPLE: lib/Myriad/Example/Call.pm 71 | 72 | The C<$api> variable is available within services for accessing the service API - see L for more details. 73 | 74 | =cut 75 | -------------------------------------------------------------------------------- /lib/Myriad/Mutex.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Mutex; 2 | use Myriad::Class qw(:v2); 3 | 4 | # VERSION 5 | # AUTHORITY 6 | 7 | =encoding utf8 8 | 9 | =head1 NAME 10 | 11 | Myriad::Mutex - a basic mutual-exclusion primitive 12 | 13 | =head1 SYNOPSIS 14 | 15 | my $mutex = await $api->mutex; 16 | 17 | =head1 DESCRIPTION 18 | 19 | =cut 20 | 21 | use Math::Random::Secure; 22 | 23 | field $key; 24 | field $id; 25 | field $storage; 26 | field $ttl; 27 | field $loop; 28 | 29 | field $acquired; 30 | 31 | BUILD (%args) { 32 | $id = delete $args{id}; 33 | $key = delete $args{key}; 34 | $storage = delete $args{storage}; 35 | $ttl = delete $args{ttl} // 60; 36 | $loop = delete $args{loop} // IO::Async::Loop->new; 37 | die 'invalid remaining keys in %args - '. join ',', sort keys %args if %args; 38 | } 39 | 40 | async method removal_watch { 41 | } 42 | 43 | async method acquire { 44 | while(1) { 45 | if( 46 | my $res = await $storage->set_unless_exists( 47 | $key => $id, 48 | $ttl, 49 | ) 50 | ) { 51 | $log->debugf('Mutex [%s] lost to [%s]', $key, $res); 52 | my $removed = $storage->when_key_changed($key); 53 | await Future->wait_any( 54 | $loop->delay_future(after => 3 + rand), 55 | also => $removed, 56 | ) if await $storage->get($key); 57 | } else { 58 | $log->debugf('Acquired mutex [%s]', $key); 59 | $acquired = 1; 60 | return $self; 61 | } 62 | 63 | # Slight delay between attempts 64 | await $loop->delay_future(after => 0.01 * rand); 65 | } 66 | } 67 | 68 | async method release { 69 | return undef unless $acquired; 70 | $log->debugf('Release mutex [%s]', $key); 71 | await $storage->del($key); 72 | $acquired = 0; 73 | return undef; 74 | } 75 | 76 | method DESTROY { 77 | if(${^GLOBAL_PHASE} eq 'DESTRUCT') { 78 | $log->warnf('Mutex [%s] still acquired at global destruction time', $key) 79 | if $acquired; 80 | return; 81 | } 82 | 83 | $self->release->retain; 84 | } 85 | 86 | 1; 87 | 88 | __END__ 89 | 90 | =head1 AUTHOR 91 | 92 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 93 | 94 | See L for full details. 95 | 96 | =head1 LICENSE 97 | 98 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 99 | 100 | -------------------------------------------------------------------------------- /lib/Myriad/Plugin.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Plugin; 2 | 3 | use Myriad::Class; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Plugin - extensible L functionality using attributes 13 | 14 | =head1 DESCRIPTION 15 | 16 | The plugin system allows sharing of various features between service implementations. 17 | Examples might include database or API access. 18 | 19 | Plugins will be loaded automatically if an as-yet-unknown attribute is used. 20 | 21 | For example, a hypothetical C<< async method example : Reverse() { } >> service method 22 | definition would attempt to use the registered C handler, and if none was found 23 | would proceed to load C<< Myriad::Plugin::Reverse >> and try again. 24 | 25 | =cut 26 | 27 | # Normal access is through this singleton, but we do allow 28 | # separate instances in unit tests. Note that this is the top-level 29 | # Myriad::Plugin instance only, and does not affect the subclass 30 | # instances. 31 | our $REGISTRY = __PACKAGE__->new; 32 | 33 | field $plugin; 34 | 35 | =head1 METHODS 36 | 37 | =cut 38 | 39 | =head2 register 40 | 41 | Example: 42 | 43 | field $db; 44 | register SQL => async method ($code, %args) { 45 | return $self->$curry::weak(method ($srv, @args) { 46 | my ($sql, @bind) = $srv->$code(@args); 47 | return $db->query( 48 | $sql => @bind 49 | )->row_hashrefs 50 | }) 51 | }; 52 | 53 | =cut 54 | 55 | async method register ($attr, $code) { 56 | $log->tracef('Registering plugin %s for %s', $code, $attr); 57 | die 'already have ' . $attr if exists $plugin->{$attr}; 58 | $plugin->{$attr} = $code; 59 | } 60 | 61 | async method apply_to_service ($srv, $method, $attr) { 62 | $log->tracef('Applying plugin for %s to %s on %s', $attr, $method, $srv); 63 | } 64 | 65 | sub import { 66 | my ($called_on, %args) = @_; 67 | return undef unless $called_on eq __PACKAGE__; 68 | my $pkg = caller(0); 69 | my $meta = Myriad::Class->import(target => $pkg); 70 | no strict 'refs'; 71 | *{$pkg . '::register'} = sub ($attr, $code) { 72 | $REGISTRY->register($attr, $code); 73 | } 74 | } 75 | 76 | 1; 77 | 78 | =head1 AUTHOR 79 | 80 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 81 | 82 | See L for full details. 83 | 84 | =head1 LICENSE 85 | 86 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 87 | 88 | -------------------------------------------------------------------------------- /lib/Myriad/RPC.pm: -------------------------------------------------------------------------------- 1 | package Myriad::RPC; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | use utf8; 10 | 11 | =encoding utf8 12 | 13 | =head1 NAME 14 | 15 | Myriad::RPC - microservice RPC abstraction 16 | 17 | =head1 SYNOPSIS 18 | 19 | my $rpc = $myriad->rpc; 20 | 21 | =head1 DESCRIPTION 22 | 23 | =cut 24 | 25 | no indirect qw(fatal); 26 | use Scalar::Util qw(weaken); 27 | 28 | use Myriad::Exception::Builder category => 'rpc'; 29 | 30 | =head1 Exceptions 31 | 32 | =cut 33 | 34 | =head2 InvalidRequest 35 | 36 | Returned when there is issue parsing the request, or if the request parameters are incomplete. 37 | 38 | =cut 39 | 40 | declare_exception InvalidRequest => ( 41 | message => 'Invalid request' 42 | ); 43 | 44 | =head2 MethodNotFound 45 | 46 | Returned if the requested method is not recognized by the service. 47 | 48 | =cut 49 | 50 | declare_exception MethodNotFound => ( 51 | message => 'Method not found' 52 | ); 53 | 54 | =head2 Timeout 55 | 56 | Returned when there is an external timeout or the request deadline is already passed. 57 | 58 | =cut 59 | 60 | declare_exception Timeout => ( 61 | message => 'Timeout' 62 | ); 63 | 64 | =head2 BadEncoding 65 | 66 | Returned when the service is unable to decode/encode the request correctly. 67 | 68 | =cut 69 | 70 | declare_exception BadEncoding => ( 71 | message => 'Bad encoding' 72 | ); 73 | 74 | =head2 UnknownTransport 75 | 76 | RPC transport does not exist. 77 | 78 | =cut 79 | 80 | declare_exception UnknownTransport => ( 81 | message => 'Unknown transport' 82 | ); 83 | 84 | =head1 METHODS 85 | 86 | =cut 87 | 88 | sub new { 89 | my ($class, %args) = @_; 90 | my $transport = delete $args{transport}; 91 | weaken(my $myriad = delete $args{myriad}); 92 | # Passing args individually looks tedious but this is to avoid 93 | # L exception when it doesn't recognize the key. 94 | 95 | if ($transport eq 'redis') { 96 | require Myriad::RPC::Implementation::Redis; 97 | return Myriad::RPC::Implementation::Redis->new( 98 | redis => $myriad->redis_transport, 99 | ); 100 | } elsif($transport eq 'memory' or $transport eq 'perl') { 101 | require Myriad::RPC::Implementation::Memory; 102 | return Myriad::RPC::Implementation::Memory->new( 103 | transport => $myriad->memory_transport, 104 | ); 105 | } else { 106 | Myriad::Exception::RPC::UnknownTransport->throw; 107 | } 108 | } 109 | 110 | 1; 111 | 112 | __END__ 113 | 114 | =head1 AUTHOR 115 | 116 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 117 | 118 | See L for full details. 119 | 120 | =head1 LICENSE 121 | 122 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 123 | 124 | -------------------------------------------------------------------------------- /lib/Myriad/RPC/Client.pm: -------------------------------------------------------------------------------- 1 | package Myriad::RPC::Client; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | use utf8; 10 | 11 | =encoding utf8 12 | 13 | =head1 NAME 14 | 15 | Myriad::RPC::Client - microservice RPC client abstraction 16 | 17 | =head1 SYNOPSIS 18 | 19 | my $client = $myriad->rpc_client; 20 | 21 | =head1 DESCRIPTION 22 | 23 | =cut 24 | 25 | no indirect qw(fatal); 26 | use Scalar::Util qw(weaken); 27 | 28 | use Myriad::Exception::Builder category => 'rpc_client'; 29 | 30 | =head2 Exceptions 31 | 32 | =cut 33 | 34 | =head2 RPCFailed 35 | 36 | The RPC call has been performed correctly but the results are an error. 37 | 38 | =cut 39 | 40 | declare_exception RPCFailed => (message => 'Your operation failed'); 41 | 42 | =head2 UnknownTransport 43 | 44 | RPC transport does not exist. 45 | 46 | =cut 47 | 48 | declare_exception UnknownTransport => ( 49 | message => 'Unknown transport' 50 | ); 51 | 52 | sub new { 53 | my ($class, %args) = @_; 54 | my $transport = delete $args{transport}; 55 | weaken(my $myriad = delete $args{myriad}); 56 | # Passing args individually looks tedious but this is to avoid 57 | # L exception when it doesn't recognize the key. 58 | 59 | if ($transport eq 'redis') { 60 | require Myriad::RPC::Client::Implementation::Redis; 61 | return Myriad::RPC::Client::Implementation::Redis->new( 62 | redis => $myriad->redis_transport, 63 | ); 64 | } elsif ($transport eq 'memory' or $transport eq 'perl') { 65 | require Myriad::RPC::Client::Implementation::Memory; 66 | return Myriad::RPC::Client::Implementation::Memory->new( 67 | transport => $myriad->memory_transport 68 | ); 69 | } else { 70 | Myriad::Exception::RPC::Client::UnknownTransport->throw(); 71 | } 72 | } 73 | 74 | 1; 75 | 76 | =head1 AUTHOR 77 | 78 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 79 | 80 | See L for full details. 81 | 82 | =head1 LICENSE 83 | 84 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 85 | 86 | -------------------------------------------------------------------------------- /lib/Myriad/RPC/Client/Implementation/Memory.pm: -------------------------------------------------------------------------------- 1 | package Myriad::RPC::Client::Implementation::Memory; 2 | 3 | use Myriad::Class extends => qw(IO::Async::Notifier); 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::RPC::Client::Implementation::Memory 13 | 14 | =head1 SYNOPSIS 15 | 16 | =head1 DESCRIPTION 17 | 18 | =cut 19 | 20 | use Myriad::Util::UUID; 21 | use Myriad::RPC::Message; 22 | 23 | field $transport; 24 | field $whoami; 25 | field $current_id; 26 | field $subscription; 27 | field $pending_requests; 28 | field $started; 29 | 30 | BUILD { 31 | $whoami = Myriad::Util::UUID::uuid(); 32 | $current_id = 0; 33 | $pending_requests = {}; 34 | } 35 | 36 | method configure (%args) { 37 | $transport = delete $args{transport} if $args{transport}; 38 | } 39 | 40 | method is_started() { 41 | return defined $started ? $started : Myriad::Exception::InternalError->new(message => '->start was not called')->throw; 42 | } 43 | 44 | async method start { 45 | $started = $self->loop->new_future(label => 'rpc_client_subscription'); 46 | my $sub = await $transport->subscribe($whoami); 47 | $subscription = $sub->each(sub { 48 | try { 49 | my $payload = $_; 50 | my $message = Myriad::RPC::Message::from_json($payload); 51 | if(my $pending = delete $pending_requests->{$message->message_id}) { 52 | return $pending->done($message); 53 | } 54 | } catch ($e) { 55 | $log->warnf('failed to parse rpc response due %s', $e); 56 | } 57 | })->completed(); 58 | 59 | $started->done('started'); 60 | 61 | await $subscription; 62 | } 63 | 64 | async method stop { 65 | $subscription->done(); 66 | } 67 | 68 | async method call_rpc ($service, $method, %args) { 69 | my $pending = $self->loop->new_future(label => "rpc_request::${service}::{$method}"); 70 | 71 | my $deadline = time + 5; 72 | my $message_id = $current_id++; 73 | 74 | my $request = Myriad::RPC::Message->new( 75 | rpc => $method, 76 | who => $whoami, 77 | deadline => $deadline, 78 | message_id => $message_id, 79 | args => \%args, 80 | ); 81 | 82 | $pending_requests->{$message_id} = $pending; 83 | await $self->is_started(); 84 | await $transport->add_to_stream("service.$service.rpc/$method", $request->as_hash->%*); 85 | 86 | try { 87 | my $message = await Future->wait_any( 88 | $self->loop->timeout_future(at => $deadline), 89 | $pending 90 | ); 91 | if(my $err = $message->response->{error}) { 92 | Myriad::Exception::InternalError->new( 93 | reason => $err 94 | )->throw; 95 | } 96 | return $message->response->{response}; 97 | } catch ($e) { 98 | if ($e =~ /Timeout/) { 99 | $e = Myriad::Exception::RPC::Timeout->new( 100 | reason => 'deadline is due' 101 | ); 102 | } else { 103 | $e = Myriad::Exception::InternalError->new( 104 | reason => $e 105 | ) unless blessed $e && $e->DOES('Myriad::Exception'); 106 | } 107 | $pending->fail($e) unless $pending->is_ready; 108 | delete $pending_requests->{$message_id}; 109 | $e->throw(); 110 | } 111 | } 112 | 113 | method _add_to_loop ($loop) { 114 | $self->adopt_future($self->start); 115 | $self->next::method($loop); 116 | } 117 | 118 | 1; 119 | 120 | =head1 AUTHOR 121 | 122 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 123 | 124 | See L for full details. 125 | 126 | =head1 LICENSE 127 | 128 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 129 | 130 | -------------------------------------------------------------------------------- /lib/Myriad/RPC/Client/Implementation/Redis.pm: -------------------------------------------------------------------------------- 1 | package Myriad::RPC::Client::Implementation::Redis; 2 | 3 | use Myriad::Class extends => qw(IO::Async::Notifier); 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::RPC::Client::Implementation::Redis - microservice RPC client abstraction 13 | 14 | =head1 SYNOPSIS 15 | 16 | =head1 DESCRIPTION 17 | 18 | =cut 19 | 20 | use Myriad::Util::UUID; 21 | use Myriad::RPC::Implementation::Redis qw(stream_name_from_service); 22 | use Myriad::RPC::Message; 23 | 24 | use constant DEFAULT_RPC_TIMEOUT_SECONDS => 30; 25 | 26 | field $redis; 27 | field $subscription; 28 | field $pending_requests; 29 | field $whoami; 30 | field $current_id; 31 | field $started; 32 | 33 | BUILD { 34 | $pending_requests = {}; 35 | $whoami = Myriad::Util::UUID::uuid(); 36 | $current_id = 0; 37 | } 38 | 39 | method configure (%args) { 40 | $redis = delete $args{redis} if $args{redis}; 41 | } 42 | 43 | method is_started() { 44 | return defined($started) 45 | ? $started 46 | : Myriad::Exception::InternalError->new(message => '->start was not called')->throw; 47 | } 48 | 49 | async method start() { 50 | $started = $self->loop->new_future(label => 'rpc_client_subscription'); 51 | my $sub = await $redis->subscribe($whoami); 52 | $subscription = $sub->map(sub{ 53 | try { 54 | my $payload = $_; 55 | $log->tracef('Received RPC response as %s', $payload); 56 | 57 | my $message = Myriad::RPC::Message::from_json($payload); 58 | 59 | if(my $pending = delete $pending_requests->{$message->message_id}) { 60 | return $pending->done($message); 61 | } 62 | $log->tracef('No pending future for message %s', $message->message_id); 63 | } catch ($e) { 64 | $log->warnf('failed to parse rpc response due %s', $e); 65 | } 66 | }); 67 | 68 | $started->done('started'); 69 | $log->tracef('Started RPC client subscription on %s', $whoami); 70 | return; 71 | } 72 | 73 | async method call_rpc($service, $method, %args) { 74 | my $pending = $self->loop->new_future(label => "rpc::request::${service}::${method}"); 75 | 76 | my $message_id = $self->next_id; 77 | my $timeout = delete $args{timeout} || DEFAULT_RPC_TIMEOUT_SECONDS; 78 | my $deadline = time + $timeout; 79 | 80 | my $request = Myriad::RPC::Message->new( 81 | rpc => $method, 82 | who => $whoami, 83 | deadline => $deadline, 84 | message_id => $message_id, 85 | args => \%args, 86 | ); 87 | 88 | try { 89 | await $self->is_started(); 90 | 91 | $log->tracef('Sending rpc::request::%s::%s : %s', $service, $method, $request->as_hash); 92 | my $stream_name = stream_name_from_service($service, $method); 93 | $pending_requests->{$message_id} = $pending; 94 | await $redis->xadd($stream_name => '*', $request->as_hash->%*); 95 | 96 | # The subscription loop will parse the message for us 97 | my $message = await Future->wait_any( 98 | $self->loop->timeout_future(after => $timeout), 99 | $pending 100 | ); 101 | 102 | if(my $err = $message->response->{error}) { 103 | Myriad::Exception::InternalError->new( 104 | reason => $err 105 | )->throw; 106 | } 107 | return $message->response->{response}; 108 | } catch ($e) { 109 | $log->warnf('Failed on RPC call - %s', $e); 110 | if ($e =~ /Timeout/) { 111 | $e = Myriad::Exception::RPC::Timeout->new( 112 | reason => 'deadline is due' 113 | ); 114 | } else { 115 | $e = Myriad::Exception::InternalError->new( 116 | reason => $e 117 | ) unless blessed $e && $e->DOES('Myriad::Exception'); 118 | } 119 | $pending->fail($e) unless $pending->is_ready; 120 | delete $pending_requests->{$message_id}; 121 | $e->throw; 122 | } 123 | } 124 | 125 | async method stop { 126 | $subscription->finish 127 | } 128 | 129 | method next_id { 130 | return $current_id++; 131 | } 132 | 133 | 1; 134 | 135 | =head1 AUTHOR 136 | 137 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 138 | 139 | See L for full details. 140 | 141 | =head1 LICENSE 142 | 143 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 144 | 145 | -------------------------------------------------------------------------------- /lib/Myriad/RPC/Message.pm: -------------------------------------------------------------------------------- 1 | package Myriad::RPC::Message; 2 | 3 | use Myriad::Class; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::RPC::Message - RPC message implementation 13 | 14 | =head1 SYNOPSIS 15 | 16 | Myriad::RPC::Message->new(); 17 | 18 | =head1 DESCRIPTION 19 | 20 | This class is to handle the decoding/encoding and verification of the RPC messages received 21 | from the transport layer. It will throw an exception when the message is invalid or doesn't 22 | match the structure. 23 | 24 | =cut 25 | 26 | use Scalar::Util qw(blessed); 27 | use Syntax::Keyword::Try; 28 | use JSON::MaybeUTF8 qw(:v1); 29 | 30 | field $rpc; 31 | field $message_id; 32 | field $transport_id; 33 | field $who; 34 | field $deadline; 35 | 36 | field $args; 37 | field $stash; 38 | field $response; 39 | field $trace; 40 | 41 | =head2 message_id 42 | 43 | The ID of the message given by the requester. 44 | 45 | =cut 46 | 47 | method message_id { $message_id } 48 | 49 | =head2 transport_id 50 | 51 | The ID of the message given by Redis, to be used in xack later. 52 | 53 | =cut 54 | 55 | method transport_id { $transport_id }; 56 | 57 | =head2 rpc 58 | 59 | The name of the procedure we are going to execute. 60 | 61 | =cut 62 | 63 | method rpc { $rpc } 64 | 65 | =head2 who 66 | 67 | A string that should identify the sender of the message for the transport. 68 | 69 | =cut 70 | 71 | method who { $who } 72 | 73 | =head2 deadline 74 | 75 | An epoch that represents when the timeout of the message. 76 | 77 | =cut 78 | 79 | method deadline { $deadline } 80 | 81 | =head2 args 82 | 83 | A JSON encoded string contains the argument of the procedure. 84 | 85 | =cut 86 | 87 | method args { $args } 88 | 89 | =head2 response 90 | 91 | The response to this message. 92 | 93 | =cut 94 | 95 | method response :lvalue { $response } 96 | 97 | =head2 stash 98 | 99 | information related to the request should be returned back to the requester. 100 | 101 | =cut 102 | 103 | method stash { $stash } 104 | 105 | =head2 trace 106 | 107 | Tracing information. 108 | 109 | =cut 110 | 111 | method trace { $trace } 112 | 113 | =head2 BUILD 114 | 115 | Build a new message. 116 | 117 | =cut 118 | 119 | BUILD(%message) { 120 | $rpc = $message{rpc}; 121 | $who = $message{who}; 122 | $message_id = $message{message_id}; 123 | $transport_id = $message{transport_id}; 124 | $deadline = $message{deadline} || time + 30; 125 | $args = $message{args} || {}; 126 | $response = $message{response} || {}; 127 | $stash = $message{stash} || {}; 128 | $trace = $message{trace} || {}; 129 | } 130 | 131 | 132 | =head2 as_hash 133 | 134 | Return a simple hash with the message data, it mustn't return nested hashes 135 | so it will convert them to JSON encoded strings. 136 | 137 | =cut 138 | 139 | method as_hash () { 140 | my $data = { 141 | rpc => $rpc, 142 | who => $who, 143 | message_id => $message_id, 144 | deadline => $deadline, 145 | }; 146 | 147 | $self->apply_encoding($data, 'utf8'); 148 | 149 | return $data; 150 | 151 | } 152 | 153 | =head2 from_hash 154 | 155 | a static method (can't be done with Object::Pad currently) that tries to 156 | parse a hash and return a L. 157 | 158 | the hash should comply with the format returned by C. 159 | 160 | =cut 161 | 162 | sub from_hash (%hash) { 163 | is_valid(\%hash); 164 | apply_decoding(\%hash, 'utf8'); 165 | 166 | return Myriad::RPC::Message->new(%hash); 167 | } 168 | 169 | =head2 as_json 170 | 171 | returns the message data as a JSON string. 172 | 173 | =cut 174 | 175 | method as_json () { 176 | my $data = { 177 | rpc => $rpc, 178 | message_id => $message_id, 179 | who => $who, 180 | deadline => $deadline, 181 | }; 182 | 183 | # This step is not necessary but I'm too lazy to repeat the keys names. 184 | $self->apply_encoding($data, 'text'); 185 | return encode_json_utf8($data); 186 | } 187 | 188 | =head2 from_json 189 | 190 | a static method that tries to parse a JSON string 191 | and return a L. 192 | 193 | =cut 194 | 195 | sub from_json ($json) { 196 | my $raw_message = decode_json_utf8($json); 197 | is_valid($raw_message); 198 | apply_decoding($raw_message, 'text'); 199 | 200 | return Myriad::RPC::Message->new($raw_message->%*); 201 | } 202 | 203 | =head2 is_valid 204 | 205 | A static method used in the C methods family to make 206 | sure that we have the needed information. 207 | 208 | =cut 209 | 210 | sub is_valid ($message) { 211 | for my $field (qw(rpc message_id who deadline args)) { 212 | Myriad::Exception::RPC::InvalidRequest->throw(reason => "$field is required") unless exists $message->{$field}; 213 | } 214 | } 215 | 216 | =head2 apply_encoding 217 | 218 | A helper method to encode the hash fields into JSON string. 219 | 220 | =cut 221 | 222 | method apply_encoding ($data, $encoding) { 223 | my $encode = $encoding eq 'text' ? \&encode_json_text : \&encode_json_utf8; 224 | try { 225 | for my $field (qw(args response stash trace)) { 226 | $data->{$field} = $encode->($self->$field); 227 | } 228 | } catch($e) { 229 | Myriad::Exception::RPC::BadEncoding->throw(reason => $e); 230 | } 231 | } 232 | 233 | =head2 apply_decoding 234 | 235 | A helper sub to decode some field from JSON string into Perl hashes. 236 | 237 | =cut 238 | 239 | sub apply_decoding ($data, $encoding) { 240 | my $decode = $encoding eq 'text' ? \&decode_json_text : \&decode_json_utf8; 241 | try { 242 | for my $field (qw(args response stash trace)) { 243 | $data->{$field} = $decode->($data->{$field}) if $data->{$field}; 244 | } 245 | } catch ($e) { 246 | Myriad::Exception::RPC::BadEncoding->throw(reason => $e); 247 | } 248 | } 249 | 250 | =head2 passed_deadline 251 | 252 | Check if the message is stil relevent 253 | 254 | =cut 255 | 256 | method passed_deadline { 257 | time > $deadline ? 1 : 0; 258 | } 259 | 260 | 1; 261 | 262 | =head1 AUTHOR 263 | 264 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 265 | 266 | See L for full details. 267 | 268 | =head1 LICENSE 269 | 270 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 271 | 272 | -------------------------------------------------------------------------------- /lib/Myriad/Redis/Pending.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Redis::Pending; 2 | 3 | use Myriad::Class; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Redis::Pending 13 | 14 | =head1 SYNOPSIS 15 | 16 | =head1 DESCRIPTION 17 | 18 | =cut 19 | 20 | field $redis; 21 | field $stream; 22 | field $group; 23 | field $id; 24 | field $finished; 25 | 26 | BUILD (%args) { 27 | $redis = $args{redis} // die 'need a redis'; 28 | $stream = $args{stream} // die 'need a stream'; 29 | $group = $args{group} // die 'need a group'; 30 | $id = $args{id} // die 'need an id'; 31 | $finished = $redis->loop->new_future->on_done($self->curry::weak::finish); 32 | } 33 | 34 | =head2 finished 35 | 36 | Returns a L representing the state of this message - C means that 37 | it has been acknowledged. 38 | 39 | =cut 40 | 41 | method finished () { $finished } 42 | 43 | =head2 finish 44 | 45 | Should be called once processing is complete. 46 | 47 | This is probably in the wrong place - better to have this as a simple abstract class. 48 | 49 | =cut 50 | 51 | async method finish () { 52 | await $redis->xack($stream, $group, $id) 53 | } 54 | 55 | 1; 56 | 57 | =head1 AUTHOR 58 | 59 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 60 | 61 | See L for full details. 62 | 63 | =head1 LICENSE 64 | 65 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 66 | 67 | -------------------------------------------------------------------------------- /lib/Myriad/Role.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Role; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | use utf8; 10 | 11 | =encoding utf8 12 | 13 | =head1 NAME 14 | 15 | Myriad::Role - common pragmata for L rôles 16 | 17 | =head1 SYNOPSIS 18 | 19 | package Example::Role; 20 | use Myriad::Role; 21 | 22 | requires startup; 23 | 24 | 1; 25 | 26 | =cut 27 | 28 | require Myriad::Class; 29 | 30 | sub import { 31 | my $called_on = shift; 32 | 33 | # Unused, but we'll support it for now. 34 | my $version = 1; 35 | if(@_ and $_[0] =~ /^:v([0-9]+)/) { 36 | $version = $1; 37 | shift; 38 | } 39 | my %args = ( 40 | version => $version, 41 | @_ 42 | ); 43 | 44 | my $class = __PACKAGE__; 45 | my $pkg = delete($args{target}) // caller(0); 46 | $args{type} = 'role'; 47 | $args{target} //= $pkg; 48 | return Myriad::Class->import(%args); 49 | } 50 | 51 | 1; 52 | 53 | __END__ 54 | 55 | =head1 AUTHOR 56 | 57 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 58 | 59 | See L for full details. 60 | 61 | =head1 LICENSE 62 | 63 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 64 | 65 | -------------------------------------------------------------------------------- /lib/Myriad/Role/RPC.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Role::RPC; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | use utf8; 10 | 11 | =encoding utf8 12 | 13 | =head1 NAME 14 | 15 | Myriad::Role::RPC - microservice RPC abstraction 16 | 17 | =head1 SYNOPSIS 18 | 19 | my $rpc = $myriad->rpc; 20 | 21 | =head1 DESCRIPTION 22 | 23 | =head1 Implementation 24 | 25 | Note that this is defined as a rôle, so it does not provide 26 | a concrete implementation - instead, see classes such as: 27 | 28 | =over 4 29 | 30 | =item * L 31 | 32 | =item * L 33 | 34 | =back 35 | 36 | =cut 37 | 38 | no indirect qw(fatal); 39 | use Role::Tiny; 40 | 41 | use Future::AsyncAwait; 42 | 43 | use Myriad::RPC::Message; 44 | 45 | =head1 METHODS 46 | 47 | The following methods are required in any concrete classes which implement this rôle. 48 | 49 | =head2 start 50 | 51 | Activate RPC - begin listening for messages. 52 | 53 | Expected to return a L which resolves once we think this instance is ready 54 | and able to process requests. 55 | 56 | =cut 57 | 58 | requires 'start'; 59 | 60 | =head2 create_from_sink 61 | 62 | Register a new RPC method and attach a L to be able to publish messages when they are received. 63 | 64 | =cut 65 | 66 | requires 'create_from_sink'; 67 | 68 | =head2 stop 69 | 70 | Deäctivate RPC - stop listening for messages. 71 | 72 | This is the counterpart to L. 73 | 74 | Expected to return a L which resolves once we are guaranteed not to pick up 75 | any further new requests. 76 | 77 | =cut 78 | 79 | requires 'stop'; 80 | 81 | =head2 reply_success 82 | 83 | Reply back to the sender of the message with success payload. 84 | The method will take the raw response and take care of how we are going to encapsulate it. 85 | 86 | =over 4 87 | 88 | =item * message - The message we are processing. 89 | 90 | =item * response - The success response. 91 | 92 | =back 93 | 94 | =cut 95 | 96 | requires 'reply_success'; 97 | 98 | =head2 reply_error 99 | 100 | Same concept of C but for errors. 101 | 102 | =over 4 103 | 104 | =item * C - the message we are processing 105 | 106 | =item * C - the L that happened while processing the message 107 | 108 | =back 109 | 110 | =cut 111 | 112 | requires 'reply_error'; 113 | 114 | =head2 drop 115 | 116 | This should be used to handle dead messages (messages that we couldn't even parse). 117 | 118 | It doesn't matter how the implementation is going to deal with it (delete it/ move it to another queue ..etc) the RPC handler 119 | should call this method when it's unable to parse a message and we can't reply to the client. 120 | 121 | =over 4 122 | 123 | =item * C - message id 124 | 125 | =back 126 | 127 | =cut 128 | 129 | requires 'drop'; 130 | 131 | 1; 132 | 133 | __END__ 134 | 135 | =head1 AUTHOR 136 | 137 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 138 | 139 | See L for full details. 140 | 141 | =head1 LICENSE 142 | 143 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 144 | 145 | -------------------------------------------------------------------------------- /lib/Myriad/Role/Subscription.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Role::Subscription; 2 | 3 | use Myriad::Class type => 'role'; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Subscription - microservice subscription abstraction 13 | 14 | =head1 SYNOPSIS 15 | 16 | my $storage = $myriad->subscription; 17 | 18 | =head1 DESCRIPTION 19 | 20 | =head1 Implementation 21 | 22 | Note that this is defined as a rôle, so it does not provide 23 | a concrete implementation - instead, see classes such as: 24 | 25 | =over 4 26 | 27 | =item * L 28 | 29 | =item * L 30 | 31 | =back 32 | 33 | =cut 34 | 35 | =head1 METHODS 36 | 37 | =head2 create_from_sink 38 | 39 | Register a new C to notify it when there is new data. 40 | 41 | it takes a hash as an argument that should have the following 42 | 43 | =over 4 44 | 45 | =item * C - a L that the subscription will emit new messages to. 46 | 47 | =item * C - The events channel name where the C will emit the new events. 48 | 49 | =item * C - The name that this C should use while fetching new events. 50 | 51 | =back 52 | 53 | =cut 54 | 55 | method create_from_sink; 56 | 57 | =head2 create_from_source 58 | 59 | Register a new C to receive events from. 60 | 61 | it takes a hash as an argument that should have the following 62 | 63 | =over 4 64 | 65 | =item * C - a L where the messages will be emitted to. 66 | 67 | =item * C - The name of the events channel that should be used to send the messages to. 68 | 69 | =back 70 | 71 | =cut 72 | 73 | method create_from_source; 74 | 75 | =head2 start 76 | 77 | Start processing the subscriptions. 78 | 79 | =cut 80 | 81 | method start; 82 | 83 | =head2 stop 84 | 85 | Stop processing the subscriptions. 86 | 87 | =cut 88 | 89 | method stop; 90 | 91 | 1; 92 | 93 | __END__ 94 | 95 | =head1 AUTHOR 96 | 97 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 98 | 99 | See L for full details. 100 | 101 | =head1 LICENSE 102 | 103 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 104 | 105 | -------------------------------------------------------------------------------- /lib/Myriad/Service.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Service; 2 | 3 | use Myriad::Class; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Service - starting point for building microservices 13 | 14 | =head1 SYNOPSIS 15 | 16 | package Example::Service; 17 | use Myriad::Service; 18 | 19 | async method startup { 20 | $log->infof('Starting %s', __PACKAGE__); 21 | } 22 | 23 | # Trivial RPC call, provides the `example` method 24 | async method example : RPC { 25 | return { ok => 1 }; 26 | } 27 | 28 | # Slightly more useful - return all the original parameters. 29 | # Due to an unfortunate syntactical choice in core Perl, the 30 | # whitespace before the (%args) is *mandatory*, without that 31 | # you're actually passing (%args) to the RPC attribute... 32 | async method echo : RPC (%args) { 33 | return \%args; 34 | } 35 | 36 | # Default internal diagnostics checks are performed automatically, 37 | # this method is called after the microservice status such as Redis 38 | # connections, exception status etc. are verified 39 | async method diagnostics ($level) { 40 | my ($self, $level) = @_; 41 | return 'ok'; 42 | } 43 | 44 | 1; 45 | 46 | =head1 DESCRIPTION 47 | 48 | Since this is a framework, by default it attempts to enforce a common standard on all microservice 49 | modules. See L for the details. 50 | 51 | The calling package will be marked as an L class, providing the 52 | L, L and C keywords. 53 | 54 | This also makes available a L instance in the C<$log> package variable, 55 | and for L support you get C<$tracer> as an L 56 | instance. 57 | 58 | =head2 Custom language features 59 | 60 | B by specifying C<< :custom >> as an L parameter: 61 | 62 | package Example::Service; 63 | use strict; 64 | use warnings; 65 | use Myriad::Service qw(:custom); 66 | use Log::Any qw($log); 67 | 68 | This will only apply the L parent class, and avoid 69 | any changes to syntax or other features. 70 | 71 | =cut 72 | 73 | use Heap; 74 | use IO::Async::Notifier; 75 | use IO::Async::SSL; 76 | use Net::Async::HTTP; 77 | 78 | use Myriad::Service::Implementation; 79 | use Myriad::Config; 80 | 81 | use Myriad::Exception::Builder category => 'service'; 82 | 83 | declare_exception SecureDefaultValue => ( 84 | message => 'Secure configuration parameter may not have a default value' 85 | ); 86 | 87 | our %SLOT; 88 | 89 | sub import ($called_on, @args) { 90 | my $class = __PACKAGE__; 91 | my $pkg = caller(0); 92 | $INC{($pkg =~ s{::}{/}gr) . '.pm'} //= 1; 93 | 94 | if(grep { $_ eq ':custom' } @args) { 95 | push @{$pkg . '::ISA' }, 'Myriad::Service::Implementation', 'Myriad::Service'; 96 | return; 97 | } 98 | 99 | my $version = 1; 100 | if(@args and $args[0] =~ /^:v([0-9]+)/) { 101 | $version = $1; 102 | } 103 | 104 | my $meta = Myriad::Class->import( 105 | ":v$version", 106 | target => $pkg, 107 | extends => 'Myriad::Service::Implementation', 108 | ); 109 | 110 | # Now we populate various slots, to be filled in when instantiating. 111 | # Currently we have `$api`, but might be helpful to provide `$storage` 112 | # and others directly here. 113 | $SLOT{$pkg} = { 114 | map { $_ => $meta->add_field('$' . $_) } qw( 115 | api 116 | ) 117 | }; 118 | 119 | { 120 | no strict 'refs'; 121 | 122 | push @{$pkg . '::ISA' }, 'Myriad::Service'; 123 | 124 | *{$pkg . '::config'} = sub { 125 | my ($varname, %args) = @_; 126 | die 'config name is required' unless $varname; 127 | 128 | Myriad::Exception::Service::SecureDefaultValue->throw 129 | if defined($args{default}) and $args{secure}; 130 | 131 | $Myriad::Config::SERVICES_CONFIG{$pkg}->{$varname} = \%args; 132 | 133 | $log->tracef("registered config %s for service %s", $varname, $pkg); 134 | } 135 | } 136 | return; 137 | } 138 | 139 | 1; 140 | 141 | =head1 AUTHOR 142 | 143 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 144 | 145 | See L for full details. 146 | 147 | =head1 LICENSE 148 | 149 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 150 | 151 | -------------------------------------------------------------------------------- /lib/Myriad/Service/Attributes.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Service::Attributes; 2 | 3 | use Myriad::Class class => ''; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Service::Attributes - microservice coördination 13 | 14 | =head1 SYNOPSIS 15 | 16 | =head1 DESCRIPTION 17 | 18 | =cut 19 | 20 | =head1 Attributes 21 | 22 | Each of these is an attribute that can be applied to a method. 23 | 24 | Note that this class is just a simple passthrough to L, 25 | which does all the real work. 26 | 27 | =cut 28 | 29 | use Attribute::Storage qw(get_subattr); 30 | 31 | use Myriad::Registry; 32 | 33 | use List::Util qw(pairmap); 34 | use Sub::Util (); 35 | 36 | our %KNOWN_ATTRIBUTES = map {; 37 | my ($sym) = /[A-Za-z0-9_]+/g; 38 | $sym => $sym 39 | } pairmap { 40 | my $attr = get_subattr($b->reference, 'ATTR'); 41 | ($attr && $attr->{code}) 42 | ? $a 43 | : () 44 | } meta::get_this_package()->list_symbols(sigils => '&'); 45 | 46 | =head1 METHODS 47 | 48 | =head2 apply_attributes 49 | 50 | Due to L limitations at runtime, we need to pick 51 | up attributes ourselves. 52 | 53 | =cut 54 | 55 | =head2 RPC 56 | 57 | Mark this async method as a callable RPC method. 58 | 59 | async method example_rpc : RPC (%args) { 60 | return \%args; 61 | } 62 | 63 | This will cause the method to be registered in L. 64 | 65 | =cut 66 | 67 | sub RPC:ATTR(CODE,NAME) ($class, $method_name, @args) { 68 | require Myriad; 69 | my $code = $class->can($method_name); 70 | $Myriad::REGISTRY->add_rpc( 71 | $class, 72 | $method_name, 73 | $code, 74 | +{ @args } 75 | ); 76 | } 77 | 78 | =head2 Batch 79 | 80 | Mark this as an async method which should be called repeatedly to generate 81 | arrayref batches of data. 82 | 83 | Takes the following parameters as a hashref: 84 | 85 | =over 4 86 | 87 | =item * C - compress all data, regardless of size 88 | 89 | =item * C - compress any data which would be larger than the given size after encoding, in bytes 90 | 91 | =back 92 | 93 | field $id = 0; 94 | async method example_batch : Batch { 95 | return [ ++$id ]; 96 | } 97 | 98 | =cut 99 | 100 | sub Batch:ATTR(CODE,NAME) ($class, $method_name, @args) { 101 | require Myriad; 102 | my $code = $class->can($method_name); 103 | $Myriad::REGISTRY->add_batch( 104 | $class, 105 | $method_name, 106 | $code, 107 | +{ @args } 108 | ); 109 | } 110 | 111 | =head2 Emitter 112 | 113 | Indicates a method which should be called on startup, which given a 114 | L will emit events to that sink until it's done. 115 | 116 | Takes the following parameters as a hashref: 117 | 118 | =over 4 119 | 120 | =item * C - compress all data, regardless of size 121 | 122 | =item * C - compress any data which would be larger than the given size after encoding, in bytes 123 | 124 | =item * C - emit to zero or more separate streams defined by this key in the emitted items 125 | 126 | =back 127 | 128 | =cut 129 | 130 | sub Emitter:ATTR(CODE,NAME) ($class, $method_name, @args) { 131 | require Myriad; 132 | my $code = $class->can($method_name); 133 | $Myriad::REGISTRY->add_emitter( 134 | $class, 135 | $method_name, 136 | $code, 137 | +{ @args } 138 | ); 139 | } 140 | 141 | =head2 Receiver 142 | 143 | Indicates a method which should be called on startup and passed a 144 | L. Events will be emitted to that source until termination. 145 | 146 | =cut 147 | 148 | sub Receiver:ATTR(CODE,NAME) ($class, $method_name, @args) { 149 | require Myriad; 150 | my $code = $class->can($method_name); 151 | $Myriad::REGISTRY->add_receiver( 152 | $class, 153 | $method_name, 154 | $code, 155 | +{ @args } 156 | ); 157 | } 158 | 159 | 1; 160 | 161 | =head1 AUTHOR 162 | 163 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 164 | 165 | See L for full details. 166 | 167 | =head1 LICENSE 168 | 169 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 170 | 171 | -------------------------------------------------------------------------------- /lib/Myriad/Service/Bus.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Service::Bus; 2 | 3 | use Myriad::Class; 4 | 5 | field $events : reader; 6 | field $transport; 7 | field $service_name; 8 | 9 | BUILD (%args) { 10 | $service_name = $args{service}; 11 | $events = $args{myriad}->ryu->source; 12 | $transport = $args{myriad}->transport('storage'); 13 | } 14 | 15 | async method setup { 16 | # We currently pass through the events to the main source, and 17 | # don't support backpressure - for small volumes this works, but 18 | # the longer-term intention is to decant heavy subscription streams 19 | # onto their own connection so we can pause reading without affecting 20 | # other functionality. 21 | my $sub = await $transport->subscribe('event.{' . $service_name . '}'); 22 | $sub->each(sub { 23 | $events->emit($_); 24 | })->retain; 25 | return $sub; 26 | } 27 | 28 | 1; 29 | -------------------------------------------------------------------------------- /lib/Myriad/Service/Remote.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Service::Remote; 2 | 3 | # VERSION 4 | # AUTHORITY 5 | 6 | =encoding utf8 7 | 8 | =head1 NAME 9 | 10 | Myriad::Service::Remote - abstraction to access other services over the network. 11 | 12 | =head1 SYNOPSIS 13 | 14 | my $remote_service = $api->service_by_name('service'); 15 | await $remote_service->call_api('some_method', %args); 16 | 17 | =head1 DESCRIPTION 18 | 19 | =cut 20 | 21 | use Myriad::Class; 22 | use Myriad::Service::Storage::Remote; 23 | use Myriad::Service::Remote::RPC; 24 | use Myriad::Service::Remote::Bus; 25 | 26 | field $myriad; 27 | field $service_name; 28 | field $local_service_name; 29 | field $storage; 30 | 31 | BUILD(%args) { 32 | weaken($myriad = delete $args{myriad}); 33 | $service_name = delete $args{service_name} // die 'need a service name'; 34 | $local_service_name = delete $args{local_service_name}; 35 | $storage = Myriad::Service::Storage::Remote->new( 36 | prefix => $service_name, 37 | storage => $myriad->storage, 38 | local_service_name => $local_service_name 39 | ); 40 | } 41 | 42 | method service_name { $service_name } 43 | 44 | =head2 storage 45 | 46 | Returns a L instance to access 47 | the remote service public storage. 48 | 49 | =cut 50 | 51 | method storage { $storage } 52 | 53 | =head2 call_rpc 54 | 55 | Call a method on the remote service. 56 | 57 | it takes 58 | 59 | =over 4 60 | 61 | =item * C - The remote method names. 62 | 63 | =item * C - A hash of the method arguments. 64 | 65 | =back 66 | 67 | =cut 68 | 69 | async method call_rpc ($rpc, %args) { 70 | await $myriad->rpc_client->call_rpc($service_name, $rpc, %args); 71 | } 72 | 73 | method rpc () { 74 | return Myriad::Service::Remote::RPC->new( 75 | myriad => $myriad, 76 | service => $service_name, 77 | ); 78 | } 79 | 80 | method bus () { 81 | return Myriad::Service::Remote::Bus->new( 82 | myriad => $myriad, 83 | service => $service_name, 84 | ); 85 | } 86 | 87 | =head2 subscribe 88 | 89 | Please use the C attribute in Myriad. 90 | 91 | This method is implemented for the sake of compatibility with 92 | the framework specs. 93 | 94 | it subscribes to a channel in the remote service. 95 | 96 | =cut 97 | 98 | async method subscribe ($channel, $client = "remote_service") { 99 | my $sink = $myriad->ryu->sink; 100 | await $myriad->subscription->create_from_sink( 101 | sink => $sink, 102 | service => $service_name, 103 | client => $client, 104 | channel => $channel, 105 | ); 106 | return $sink->source; 107 | } 108 | 109 | 1; 110 | 111 | -------------------------------------------------------------------------------- /lib/Myriad/Service/Remote/Bus.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Service::Remote::Bus; 2 | use Myriad::Class; 3 | 4 | # VERSION 5 | # AUTHORITY 6 | 7 | =encoding utf8 8 | 9 | =head1 NAME 10 | 11 | Myriad::Service::Remote::Bus - abstraction to access events from other services 12 | 13 | =head1 SYNOPSIS 14 | 15 | 16 | =head1 DESCRIPTION 17 | 18 | =cut 19 | 20 | field $myriad : param; 21 | field $service : param; 22 | 23 | field $events; 24 | 25 | method events { 26 | unless($events) { 27 | $events = $myriad->ryu->source; 28 | my $transport = $myriad->transport('storage'); 29 | my $uuid = $service; 30 | $events->map(async sub ($item, @) { 31 | try { 32 | $log->debugf('Post to service [%s] data [%s]', $uuid, $item); 33 | await $transport->publish( 34 | 'event.{' . $uuid . '}', 35 | ref($item) ? encode_json_utf8($item) : encode_utf8($item) 36 | ) 37 | } catch ($e) { 38 | $log->errorf('Failed to send event: %s', $e); 39 | } 40 | })->resolve(low => 10, high => 100)->retain; 41 | } 42 | $log->tracef('Returning source: %s', $events); 43 | return $events; 44 | } 45 | 46 | 1; 47 | -------------------------------------------------------------------------------- /lib/Myriad/Service/Remote/RPC.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Service::Remote::RPC; 2 | 3 | # VERSION 4 | # AUTHORITY 5 | 6 | =encoding utf8 7 | 8 | =head1 NAME 9 | 10 | Myriad::Service::Remote::RPC - abstraction to access other services over the network. 11 | 12 | =head1 SYNOPSIS 13 | 14 | 15 | =head1 DESCRIPTION 16 | 17 | =cut 18 | 19 | use Myriad::Class; 20 | 21 | field $myriad : param; 22 | field $service : param; 23 | 24 | method DESTROY { } 25 | 26 | method AUTOLOAD (%args) { 27 | my ($method) = our $AUTOLOAD =~ m{^.*::([^:]+)$}; 28 | return $myriad->rpc_client->call_rpc( 29 | $service, 30 | $method => %args 31 | ); 32 | } 33 | 34 | 1; 35 | 36 | -------------------------------------------------------------------------------- /lib/Myriad/Service/Storage.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Service::Storage; 2 | 3 | use Myriad::Class; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Service::Storage - microservice storage abstraction layer 13 | 14 | =head1 SYNOPSIS 15 | 16 | my $storage = $myriad->storage; 17 | await $storage->get('some_key'); 18 | await $storage->hash_add('some_key', 'hash_key', 13); 19 | 20 | =head1 DESCRIPTION 21 | 22 | This module provides service storage access. 23 | 24 | It implements L in an object available as the C<$storage> 25 | lexical in any service class. See that module for more details on the API. 26 | 27 | =cut 28 | 29 | use Myriad::Role::Storage; 30 | use Metrics::Any qw($metrics); 31 | 32 | BEGIN { 33 | $metrics->make_timer(time_elapsed => 34 | name => [qw(myriad storage)], 35 | description => 'Time taken to process storage request', 36 | labels => [qw(method status service)], 37 | ); 38 | 39 | my $meta = Object::Pad::MOP::Class->for_class('Myriad::Service::Storage'); 40 | for my $method (@Myriad::Role::Storage::WRITE_METHODS, @Myriad::Role::Storage::READ_METHODS) { 41 | $meta->add_method($method, sub { 42 | my ($self, $key, @rest) = @_; 43 | return $self->storage->$method($self->apply_prefix($key), @rest)->on_ready(sub { 44 | my $f = shift; 45 | $metrics->report_timer(time_elapsed => $f->elapsed // 0, {method => $method, status => $f->state, service => $self->prefix}); 46 | }); 47 | }); 48 | } 49 | } 50 | 51 | field $storage; 52 | field $prefix; 53 | 54 | method storage { $storage } 55 | method prefix { $prefix } 56 | 57 | BUILD (%args) { 58 | my $service_prefix = delete $args{prefix} // die 'need a prefix'; 59 | $prefix = "service.$service_prefix"; 60 | $storage = delete $args{storage} // die 'need a storage instance'; 61 | } 62 | 63 | =head2 apply_prefix 64 | 65 | Maps the requested key into the service's keyspace 66 | so we can pass it over to the generic storage layer. 67 | 68 | Takes the following parameters: 69 | 70 | =over 4 71 | 72 | =item * C<$k> - the key 73 | 74 | =back 75 | 76 | Returns the modified key. 77 | 78 | =cut 79 | 80 | method apply_prefix ($k) { 81 | return $prefix . '/' . $k; 82 | } 83 | 84 | 1; 85 | 86 | =head1 AUTHOR 87 | 88 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 89 | 90 | See L for full details. 91 | 92 | =head1 LICENSE 93 | 94 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 95 | 96 | -------------------------------------------------------------------------------- /lib/Myriad/Service/Storage/Remote.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Service::Storage::Remote; 2 | 3 | use Myriad::Class; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Service::Storage::Remote - abstraction to access other services storage. 13 | 14 | =head1 SYNOPSIS 15 | 16 | my $storage = $api->service_by_name('service')->storage; 17 | await $storage->get('some_key'); 18 | 19 | =head1 DESCRIPTION 20 | 21 | =cut 22 | 23 | use Myriad::Role::Storage; 24 | 25 | use Metrics::Any qw($metrics); 26 | 27 | BEGIN { 28 | 29 | $metrics->make_timer(time_elapsed => 30 | name => [qw(myriad storage remote)], 31 | description => 'Time taken to process remote storage request', 32 | labels => [qw(method status service)], 33 | ); 34 | 35 | my $meta = Object::Pad::MOP::Class->for_class('Myriad::Service::Storage::Remote'); 36 | 37 | for my $method (@Myriad::Role::Storage::READ_METHODS) { 38 | $meta->add_method($method, sub { 39 | my ($self, $key, @rest) = @_; 40 | return $self->storage->$method($self->apply_prefix($key), @rest)->on_ready(sub { 41 | my $f = shift; 42 | $metrics->report_timer(time_elapsed => 43 | $f->elapsed // 0, {method => $method, status => $f->state, service => $self->local_service_name}); 44 | }); 45 | }); 46 | } 47 | } 48 | 49 | 50 | field $prefix; 51 | field $storage; 52 | field $local_service_name; 53 | method storage { $storage }; 54 | method local_service_name { $local_service_name // 'local' }; 55 | 56 | BUILD (%args) { 57 | my $service_prefix = delete $args{prefix} // die 'need a prefix'; 58 | $prefix = "service.$service_prefix"; 59 | $storage = delete $args{storage} // die 'need a storage instance'; 60 | $local_service_name = delete $args{local_service_name}; 61 | } 62 | 63 | =head2 apply_prefix 64 | 65 | Maps the requested key into the service's keyspace 66 | so we can pass it over to the generic storage layer. 67 | 68 | Takes the following parameters: 69 | 70 | =over 4 71 | 72 | =item * C<$k> - the key 73 | 74 | =back 75 | 76 | Returns the modified key. 77 | 78 | =cut 79 | 80 | method apply_prefix ($k) { 81 | return $prefix . '/' . $k; 82 | } 83 | 84 | 1; 85 | 86 | =head1 AUTHOR 87 | 88 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 89 | 90 | See L for full details. 91 | 92 | =head1 LICENSE 93 | 94 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 95 | 96 | 97 | -------------------------------------------------------------------------------- /lib/Myriad/Storage.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Storage; 2 | 3 | use Myriad::Class class => ''; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Storage - microservice Storage abstraction 13 | 14 | =head1 SYNOPSIS 15 | 16 | my $storage = Myriad::Storage->new(); 17 | 18 | =head1 DESCRIPTION 19 | 20 | =cut 21 | 22 | use Myriad::Role::Storage; 23 | 24 | use Myriad::Exception::Builder category => 'storage'; 25 | 26 | =head1 Exceptions 27 | 28 | =cut 29 | 30 | =head2 UnknownTransport 31 | 32 | RPC transport does not exist. 33 | 34 | =cut 35 | 36 | declare_exception UnknownTransport => ( 37 | message => 'Unknown transport' 38 | ); 39 | 40 | our $STORAGE; 41 | 42 | sub import { 43 | my ($class, @args) = @_; 44 | if(@args) { 45 | my ($varname) = (@args, '$storage'); 46 | $varname = $1 if $varname =~ /^\$(\w+)$/ 47 | or die 'invalid variable name ' . $varname; 48 | my $caller = caller; 49 | { 50 | no strict 'refs'; 51 | *{"${caller}::${varname}"} = weaken(\$STORAGE); 52 | } 53 | } 54 | } 55 | 56 | sub new { 57 | my ($class, %args) = @_; 58 | my $transport = delete $args{transport}; 59 | weaken(my $myriad = delete $args{myriad}); 60 | # Passing args individually looks tedious but this is to avoid 61 | # L exception when it doesn't recognize the key. 62 | 63 | if ($transport eq 'redis') { 64 | require Myriad::Storage::Implementation::Redis; 65 | $STORAGE = Myriad::Storage::Implementation::Redis->new( 66 | redis => $myriad->redis_transport, 67 | ); 68 | } elsif ($transport eq 'memory' or $transport eq 'perl') { 69 | require Myriad::Storage::Implementation::Memory; 70 | $STORAGE = Myriad::Storage::Implementation::Memory->new(); 71 | } else { 72 | Myriad::Exception::Storage::UnknownTransport->throw(); 73 | } 74 | return $STORAGE; 75 | } 76 | 77 | 1; 78 | 79 | __END__ 80 | 81 | =head1 AUTHOR 82 | 83 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 84 | 85 | See L for full details. 86 | 87 | =head1 LICENSE 88 | 89 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 90 | 91 | -------------------------------------------------------------------------------- /lib/Myriad/Subscription.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Subscription; 2 | 3 | use Myriad::Class class => ''; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Subscription - microservice subscription abstraction 13 | 14 | =head1 SYNOPSIS 15 | 16 | my $sub = Myriad::Subscription->new(); 17 | 18 | =head1 DESCRIPTION 19 | 20 | =cut 21 | 22 | no indirect qw(fatal); 23 | use Scalar::Util qw(weaken); 24 | 25 | use Myriad::Exception::Builder category => 'subscription'; 26 | 27 | =head1 Exceptions 28 | 29 | =head2 UnknownTransport 30 | 31 | Subscription transport does not exist. 32 | 33 | =cut 34 | 35 | declare_exception UnknownTransport => ( 36 | message => 'Unknown transport' 37 | ); 38 | 39 | sub new ($class, %args) { 40 | my $transport = delete $args{transport}; 41 | weaken(my $myriad = delete $args{myriad}); 42 | 43 | # Passing args individually looks tedious but this is to avoid 44 | # L exception when it doesn't recognize the key. 45 | 46 | if ($transport eq 'redis') { 47 | require Myriad::Subscription::Implementation::Redis; 48 | return Myriad::Subscription::Implementation::Redis->new( 49 | redis => $myriad->redis_transport, 50 | ); 51 | } elsif ($transport eq 'memory' or $transport eq 'perl') { 52 | require Myriad::Subscription::Implementation::Memory; 53 | return Myriad::Subscription::Implementation::Memory->new( 54 | transport => $myriad->memory_transport 55 | ); 56 | } else { 57 | Myriad::Exception::Subscription::UnknownTransport->throw(); 58 | } 59 | } 60 | 61 | 1; 62 | 63 | __END__ 64 | 65 | =head1 AUTHOR 66 | 67 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 68 | 69 | See L for full details. 70 | 71 | =head1 LICENSE 72 | 73 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 74 | 75 | -------------------------------------------------------------------------------- /lib/Myriad/Transport/HTTP.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Transport::HTTP; 2 | 3 | use Myriad::Class extends => 'IO::Async::Notifier'; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | use Net::Async::HTTP; 9 | use Net::Async::HTTP::Server; 10 | 11 | field $client; 12 | field $server; 13 | field $listener; 14 | field $requests; 15 | field $ryu; 16 | 17 | method configure (%args) { 18 | 19 | } 20 | 21 | method on_request ($srv, $req) { 22 | $requests->emit($req); 23 | $log->infof('HTTP request - %s', $req->path); 24 | my $txt = ''; 25 | my $response = HTTP::Response->new(200); 26 | $response->add_content($txt); 27 | $response->content_type("text/plain"); 28 | $response->content_length(length $txt); 29 | $req->respond($response); 30 | } 31 | 32 | method listen_port () { 2000 } 33 | 34 | method _add_to_loop ($) { 35 | $self->next::method; 36 | 37 | $self->add_child( 38 | $ryu = Ryu::Async->new 39 | ); 40 | $requests = $ryu->source; 41 | 42 | $self->add_child( 43 | $client = Net::Async::HTTP->new( 44 | ) 45 | ); 46 | $self->add_child( 47 | $server = Net::Async::HTTP::Server->new( 48 | on_request => $self->curry::weak::on_request, 49 | ) 50 | ); 51 | $listener = $server->listen( 52 | addr => { 53 | family => 'inet', 54 | socktype => 'stream', 55 | port => $self->listen_port, 56 | } 57 | ); 58 | } 59 | 60 | 1; 61 | 62 | =head1 AUTHOR 63 | 64 | Deriv Group Services Ltd. C<< DERIV@cpan.org >> 65 | 66 | =head1 LICENSE 67 | 68 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 69 | 70 | -------------------------------------------------------------------------------- /lib/Myriad/UI/Readline.pm: -------------------------------------------------------------------------------- 1 | package Myriad::UI::Readline; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | use parent qw(IO::Async::Notifier); 10 | 11 | no indirect qw(fatal); 12 | use utf8; 13 | 14 | =encoding utf8 15 | 16 | =head1 NAME 17 | 18 | Myriad::UI::Readline - L support for L 19 | 20 | =head1 DESCRIPTION 21 | 22 | Provides a basic line-based interface with history support. 23 | 24 | =cut 25 | 26 | use Syntax::Keyword::Try; 27 | use Syntax::Keyword::Dynamically; 28 | use Future::AsyncAwait; 29 | use Term::ReadLine; 30 | use Scope::Guard; 31 | 32 | use Scalar::Util qw(blessed); 33 | use Log::Any qw($log); 34 | 35 | =head1 METHODS 36 | 37 | =cut 38 | 39 | =head2 readline 40 | 41 | Returns the L instance. 42 | 43 | =cut 44 | 45 | sub readline { shift->{readline} //= Term::ReadLine->new('myriad') } 46 | 47 | =head2 setup 48 | 49 | Prepares the L instance for usage. 50 | 51 | =cut 52 | 53 | async sub setup { 54 | my ($self) = @_; 55 | my $f = $self->loop->new_future; 56 | $self->readline->event_loop(sub { 57 | $f->get; 58 | $f = $self->loop->new_future; 59 | }, sub { 60 | my ($fh) = @_; 61 | my $scope = Scope::Guard->new(sub { 62 | return if ${^GLOBAL_PHASE} eq 'DESTRUCT'; 63 | $log->tracef('Cleaning up readline watched handle'); 64 | $self->loop->unwatch_io( 65 | handle => $fh 66 | ); 67 | }); 68 | $log->tracef('Watching readline handle'); 69 | $self->loop->watch_io( 70 | handle => $fh, 71 | on_read_ready => sub { 72 | $f->done unless $f->is_ready 73 | }, 74 | ); 75 | return [ $scope ]; 76 | }); 77 | } 78 | 79 | =head2 cleanup 80 | 81 | Shut down the L instance before exit. 82 | 83 | =cut 84 | 85 | async sub cleanup { 86 | my ($self) = @_; 87 | my $rl = delete $self->{readline} or return; 88 | $rl->event_loop(undef); 89 | } 90 | 91 | =head2 handle_item 92 | 93 | Used internally to process requests. 94 | 95 | =cut 96 | 97 | async sub handle_item { 98 | my ($self, $src) = @_; 99 | if(blessed($src)) { 100 | my $int = $self->loop->new_future; 101 | $SIG{INT} = sub { # ideally would go through dynamically here 102 | $log->warnf("Ctrl-C"); 103 | $int->fail('Interrupted') unless $int->is_ready; 104 | }; 105 | if($src->isa('Ryu::Source')) { 106 | await Future->wait_any( 107 | $src->say->completed, 108 | $int, 109 | ); 110 | } elsif($src->isa('Future')) { 111 | for my $rslt (await Future->wait_any( 112 | $src, 113 | $int 114 | )) { 115 | print "$rslt\n"; 116 | } 117 | } else { 118 | $log->errorf('Unknown blessed instance returned: %s', $src); 119 | } 120 | } elsif(defined $src) { 121 | print "$src\n"; 122 | } else { 123 | print "\n"; 124 | } 125 | } 126 | 127 | =head2 run 128 | 129 | Runs the event loop for readline processing. Only resolves 130 | after completion. 131 | 132 | =cut 133 | 134 | async sub run { 135 | my ($self) = @_; 136 | my $rl = $self->readline; 137 | try { 138 | await $self->setup; 139 | my $prompt = 'myriad> '; 140 | my $active = 1; 141 | my %command = ( 142 | help => sub { 143 | return Future->done( 144 | 'No help available, sorry' 145 | ); 146 | }, 147 | infinite => sub { 148 | return $self->loop->new_future; 149 | }, 150 | exit => sub { 151 | $active = 0; 152 | return Future->done( 153 | 'Will exit eventually' 154 | ) 155 | } 156 | ); 157 | $command{quit} = $command{exit}; 158 | 159 | # The call to ->readline will enter the event loop 160 | while($active && defined(my $line = $rl->readline($prompt))) { 161 | try { 162 | my ($cmd, $args) = $line =~ /^(\S+)(?: (.*))?/s; 163 | if(my $code = $command{$cmd}) { 164 | if(my $src = $code->($args)) { 165 | # Once the call to ->readline returns, we should no longer 166 | # be in the event loop, so this ->get will reënter the event 167 | # loop long enough to complete the request 168 | $self->handle_item($src)->get; 169 | } 170 | } else { 171 | $log->errorf("Unknown command: %s", $cmd); 172 | } 173 | } catch ($e) { 174 | $log->errorf('Failed to execute %s - %s', $line, $e); 175 | } 176 | $rl->addhistory($line) if $line =~ /\S/; 177 | } 178 | } catch ($e) { 179 | $log->errorf('Failure during readline loop - %s', $e); 180 | } 181 | await $self->cleanup; 182 | } 183 | 184 | 1; 185 | 186 | =head1 AUTHOR 187 | 188 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 189 | 190 | See L for full details. 191 | 192 | =head1 LICENSE 193 | 194 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 195 | 196 | -------------------------------------------------------------------------------- /lib/Myriad/Util/Defer.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Util::Defer; 2 | 3 | use Myriad::Class type => 'role'; 4 | 5 | # VERSION 6 | # AUTHORITY 7 | 8 | =encoding utf8 9 | 10 | =head1 NAME 11 | 12 | Myriad::Util::Defer - provide a deferred wrapper attribute 13 | 14 | =head1 DESCRIPTION 15 | 16 | This is used to make an async method delay processing until later. 17 | 18 | It can be controlled by the C environment variable, 19 | and defaults to no delay. 20 | 21 | =cut 22 | 23 | use constant RANDOM_DELAY => $ENV{MYRIAD_RANDOM_DELAY} || 0; 24 | 25 | use Sub::Util; 26 | use Attribute::Storage; 27 | 28 | # Attribute for code that wants to defer execution 29 | sub Defer :ATTR(CODE,NAME) ($class, $method_name, @attrs) { 30 | my $defer = __PACKAGE__->can('defer_method'); 31 | $defer->($class, $method_name); 32 | return 1; 33 | } 34 | 35 | sub import ($class, @) { 36 | my $pkg = caller; 37 | push meta::get_package($pkg)->get_or_add_symbol(q{@ISA})->reference->@*, __PACKAGE__; 38 | return; 39 | } 40 | 41 | # Helper method that allows us to return a not-quite-immediate 42 | # Future from some inherently non-async code. 43 | sub defer_method ($package, $name) { 44 | $log->tracef('will defer handler for %s::%s by %f', $package, $name, RANDOM_DELAY); 45 | my $code = $package->can($name); 46 | my $replacement = async sub ($self, @args) { 47 | # effectively $loop->later, but in an await-compatible way: 48 | # either zero (default behaviour) or if we have a random 49 | # delay assigned, use that to drive a uniform rand() call 50 | $log->tracef('call to %s::%s, deferring start', $package, $name); 51 | await RANDOM_DELAY ? $self->loop->delay_future( 52 | after => rand(RANDOM_DELAY) 53 | ) : $self->loop->later; 54 | 55 | $log->tracef('deferred call to %s::%s runs now', $package, $name); 56 | 57 | return await $self->$code( 58 | @args 59 | ); 60 | }; 61 | { 62 | no strict 'refs'; 63 | no warnings 'redefine'; 64 | *{join '::', $package, $name} = $replacement if RANDOM_DELAY; 65 | } 66 | } 67 | 68 | 1; 69 | 70 | =head1 AUTHOR 71 | 72 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 73 | 74 | See L for full details. 75 | 76 | =head1 LICENSE 77 | 78 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 79 | 80 | -------------------------------------------------------------------------------- /lib/Myriad/Util/Secret.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Util::Secret; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | =head1 Name 10 | 11 | Myriad::Util::Secret - protect secrets from getting exposed accidentally 12 | 13 | =head1 SYNOPSIS 14 | 15 | my $secret = Myriad::Util::Secret->new('shh.. secret!'); 16 | 17 | =head1 DESCRIPTION 18 | 19 | When stringified, this will return C<***> instead of the real data. 20 | 21 | =cut 22 | 23 | use overload 24 | q{""} => sub { "***" }, 25 | eq => 'equal', 26 | ne => 'not_equal', 27 | fallback => 1; 28 | 29 | use Scalar::Util qw(blessed); 30 | 31 | # Actual secret values are stored here, so that Dumper() doesn't expose them 32 | my %secrets; 33 | 34 | sub new { 35 | my ($class, $value) = @_; 36 | die 'need secret value' unless defined $value; 37 | my $self = bless \(my $placeholder), $class; 38 | $secrets{$self} = $value; 39 | return $self; 40 | } 41 | 42 | =head2 not_equal 43 | 44 | Returns true if the secret value does not match the provided value. 45 | 46 | =cut 47 | 48 | sub not_equal { 49 | my ($self, $other) = @_; 50 | return !$self->equal($other); 51 | } 52 | 53 | =head2 equal 54 | 55 | Returns true if the secret value matches the provided value. 56 | 57 | =cut 58 | 59 | sub equal { 60 | my ($self, $other) = @_; 61 | return 0 unless defined $other; 62 | 63 | if(blessed($other) and $other->isa('Myriad::Util::Secret')) { 64 | return $other->equal($self->secret_value); 65 | } 66 | 67 | my $comparison = $secrets{$self} // ''; 68 | 69 | # Simple stepwise logic here - we start by assuming that the values _do_ match 70 | my $match = 1; 71 | 72 | # ... then we loop through the characters of the provided string, and we 73 | # mark as not matching if any of those characters don't match 74 | no warnings 'substr'; # substr out of string returns undef... 75 | no warnings 'uninitialized'; # ... so we expect and don't care for mismatched lengths 76 | for my $idx (0..length($other)) { 77 | $match = 0 if substr($other, $idx, 1) ne substr($comparison, $idx, 1); 78 | } 79 | # At this point, $match is true if the characters in the provided string match 80 | # the equivalent characters in the real string - but that's not good enough, 81 | # we need to confirm that _all_ characters were compared 82 | $match = 0 unless length($comparison) == length($other); 83 | 84 | return $match; 85 | } 86 | 87 | =head2 secret_value 88 | 89 | Returns the original secret value as text. 90 | 91 | =cut 92 | 93 | sub secret_value { 94 | my ($self) = @_; 95 | return '' . $secrets{$self} 96 | } 97 | 98 | sub DESTROY { 99 | my ($self) = @_; 100 | return if ${^GLOBAL_PHASE} eq 'DESTRUCT'; 101 | delete $secrets{$self} 102 | } 103 | 104 | 1; 105 | 106 | __END__ 107 | 108 | =head1 SEE ALSO 109 | 110 | =over 4 111 | 112 | =item * L - handles the constant-time comparison, but returns 113 | early if the string lengths are different, which is problematic since knowing the length makes 114 | attacks easier 115 | 116 | =back 117 | 118 | =head1 AUTHOR 119 | 120 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 121 | 122 | See L for full details. 123 | 124 | =head1 LICENSE 125 | 126 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 127 | 128 | -------------------------------------------------------------------------------- /lib/Myriad/Util/UUID.pm: -------------------------------------------------------------------------------- 1 | package Myriad::Util::UUID; 2 | 3 | # VERSION 4 | # AUTHORITY 5 | 6 | use strict; 7 | use warnings; 8 | 9 | use Math::Random::Secure; 10 | 11 | sub uuid { 12 | # UUIDv4 (random) 13 | my @rand = map Math::Random::Secure::irand(2**32), 1..4; 14 | return sprintf '%08x-%04x-%04x-%04x-%04x%08x', 15 | $rand[0], 16 | $rand[1] & 0xFFFF, 17 | (($rand[1] & 0x0FFF0000) >> 16) | 0x4000, 18 | $rand[2] & 0xBFFF, 19 | ($rand[2] & 0xFFFF0000) >> 16, 20 | $rand[3]; 21 | } 22 | 23 | 1; 24 | 25 | =head1 AUTHOR 26 | 27 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 28 | 29 | See L for full details. 30 | 31 | =head1 LICENSE 32 | 33 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 34 | 35 | -------------------------------------------------------------------------------- /lib/Test/Myriad.pm: -------------------------------------------------------------------------------- 1 | package Test::Myriad; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | use IO::Async::Loop; 10 | use Future::Utils qw(fmap0); 11 | use Future::AsyncAwait; 12 | use Check::UnitCheck; 13 | use Object::Pad qw(:experimental(mop)); 14 | 15 | use Myriad; 16 | use Myriad::Service::Implementation; 17 | use Test::Myriad::Service; 18 | 19 | use Log::Any::Adapter; 20 | 21 | our @REGISTERED_SERVICES; 22 | 23 | my $loop = IO::Async::Loop->new(); 24 | my $myriad = Myriad->new(); 25 | 26 | =head1 NAME 27 | 28 | Myriad::Test - a collection of helpers to test microservices. 29 | 30 | =head1 SYNOPSIS 31 | 32 | use Test::Myriad; 33 | 34 | my $mock_service = add_service(name => 'mocked_service'); 35 | 36 | =head1 DESCRIPTION 37 | 38 | A mini utility to help developers testing myriad services. 39 | 40 | it can create completely fake services or mock already 41 | existing ones. 42 | 43 | It uses the L by default to change that 44 | you can set the environment variable MYRIAD_TEST_TRANSPORT 45 | 46 | =head1 Methods 47 | 48 | =head2 add_service 49 | 50 | Adds a service to the test environment the service can be 51 | an already existing service or totally a new mocked one. 52 | 53 | it takes one of the following params: 54 | 55 | =over 4 56 | 57 | =item * C - A package name for an existing service. 58 | 59 | =item * C - A Perl package name that will hold the new mocked service. 60 | 61 | =back 62 | 63 | =cut 64 | 65 | sub add_service { 66 | my ($self, %args) = @_; 67 | my ($pkg, $meta); 68 | if (my $service = delete $args{service}) { 69 | $pkg = $service; 70 | $meta = Object::Pad::MOP::Class->for_class($service); 71 | } elsif ($service = delete $args{name}) { 72 | die 'The name should look like a Perl package name' unless $service =~ /::/; 73 | $pkg = $service; 74 | $meta = Object::Pad::MOP::Class->begin_class($pkg, extends => 'Myriad::Service::Implementation'); 75 | 76 | { 77 | no strict 'refs'; 78 | push @{$pkg . '::ISA' }, 'Myriad::Service'; 79 | $Myriad::Service::SLOT{$pkg} = { 80 | map { $_ => $meta->add_field('$' . $_) } qw(api) 81 | }; 82 | } 83 | } 84 | 85 | push @REGISTERED_SERVICES, $pkg; 86 | 87 | return Test::Myriad::Service->new(meta => $meta, pkg => $pkg, myriad => $myriad); 88 | } 89 | 90 | =head2 ready 91 | 92 | Returns a L indicate that test env 93 | is ready to be used. 94 | 95 | at the moment it is just a shortcut for L run_future. 96 | 97 | =cut 98 | 99 | sub ready { 100 | return $myriad->run_future; 101 | } 102 | 103 | =head2 instance 104 | 105 | Returns the L instance we are using 106 | 107 | =cut 108 | 109 | sub instance { 110 | return $myriad; 111 | } 112 | 113 | sub import { 114 | my $self = shift;; 115 | Check::UnitCheck::unitcheckify(sub { 116 | $myriad->configure_from_argv(('--transport', $ENV{MYRIAD_TEST_TRANSPORT} // 'memory', 'service'))->get(); 117 | 118 | # Override logger 119 | Log::Any::Adapter->set('TAP', filter => 'info'); 120 | 121 | $loop->later(sub { 122 | (fmap0 { 123 | $myriad->add_service($_); 124 | } foreach => [@REGISTERED_SERVICES])->then(sub { 125 | return $myriad->run; 126 | })->on_fail(sub { 127 | my $error = shift; 128 | die "Failed to start the test environment due: $error"; 129 | })->retain; 130 | }); 131 | }); 132 | } 133 | 134 | 1; 135 | 136 | __END__ 137 | 138 | =head1 AUTHOR 139 | 140 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 141 | 142 | See L for full details. 143 | 144 | =head1 LICENSE 145 | 146 | Copyright Deriv Group Services Ltd 2020. Licensed under the same terms as Perl itself. 147 | 148 | -------------------------------------------------------------------------------- /lib/Test/Myriad/Service.pm: -------------------------------------------------------------------------------- 1 | package Test::Myriad::Service; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | use Attribute::Storage qw(apply_subattrs_for_pkg); 10 | use Scalar::Util qw(weaken); 11 | use Sub::Util; 12 | 13 | use Myriad::Service::Implementation; 14 | use Myriad::Class; 15 | use Myriad::Service::Attributes; 16 | 17 | =head1 NAME 18 | 19 | Test::Myriad::Service - an abstraction to mock microservices. 20 | 21 | =head1 SYNOPSIS 22 | 23 | my $service = Myriad::Test::Service->new(..); 24 | $service->add_rpc('rpc_name', %default_response); 25 | 26 | =head1 DESCRIPTION 27 | 28 | =head1 Methods 29 | 30 | =cut 31 | 32 | field $name; 33 | field $pkg; 34 | field $meta_service; 35 | field $myriad; 36 | 37 | field $default_rpc; 38 | field $mocked_rpc; 39 | 40 | BUILD (%args) { 41 | $meta_service = delete $args{meta}; 42 | $pkg = delete $args{pkg}; 43 | weaken($myriad = delete $args{myriad}); 44 | 45 | $default_rpc = {}; 46 | $mocked_rpc = {}; 47 | 48 | # Replace the RPC subs with a mockable 49 | # version if the class already exists 50 | try { 51 | if (my $methods = $myriad->registry->rpc_for($pkg)) { 52 | for my $method (keys $methods->%*) { 53 | $default_rpc->{$method} = $methods->{$method}->{code}; 54 | $methods->{$method}->{code} = async sub { 55 | if ($mocked_rpc->{$method}) { 56 | return delete $mocked_rpc->{$method}; 57 | } 58 | try { 59 | my $self = shift; 60 | await $self->$method(@_); 61 | } catch ($e) { 62 | $log->tracef("An exception has been thrown while calling the original sub - %s", $e); 63 | die $e; 64 | } 65 | }; 66 | } 67 | } 68 | } catch ($e) { 69 | $log->tracef('Myriad::Registry error while checking %s, %s', $pkg, $e); 70 | } 71 | } 72 | 73 | =head2 add_rpc 74 | 75 | Attaches a new RPC to the service with a default response. 76 | 77 | =over 4 78 | 79 | =item * C - The name of the RPC. 80 | 81 | =item * C - A hash that will be sent as the response. 82 | 83 | =back 84 | 85 | =cut 86 | 87 | method add_rpc ($name, %response) { 88 | my $faker = Sub::Util::set_subname( 89 | $name, async sub { 90 | if ($mocked_rpc->{$name}) { 91 | return delete $mocked_rpc->{$name}; 92 | } elsif (my $default_response = $default_rpc->{$name}) { 93 | return $default_response; 94 | } 95 | } 96 | ); 97 | 98 | # Don't prefix the RPC name it's used in messages delivery. 99 | 100 | $default_rpc->{$name} = \%response; 101 | $meta_service->add_method($name, $faker); 102 | 103 | apply_subattrs_for_pkg( 104 | $pkg, 105 | RPC => '', 106 | $pkg->can($name), 107 | ); 108 | $self; 109 | } 110 | 111 | =head2 mock_rpc 112 | 113 | Override the original RPC response for a single call. 114 | 115 | =over 4 116 | 117 | =item * C - The name of the RPC to be mocked. 118 | 119 | =item * C - A hash that will be sent as the response. 120 | 121 | =back 122 | 123 | =cut 124 | 125 | method mock_rpc ($name, %response) { 126 | die 'You should define rpc methdos using "add_rpc" first' unless $default_rpc->{$name}; 127 | die 'You cannot mock RPC call twice' if $mocked_rpc->{$name}; 128 | $mocked_rpc->{$name} = \%response; 129 | 130 | $self; 131 | } 132 | 133 | =head2 call_rpc 134 | 135 | A shortcut to call an RPC in the current service. 136 | 137 | The call will be conducted over Myriad Transport and not 138 | as a method invocation. 139 | 140 | =over 4 141 | 142 | =item * C - The RPC method name. 143 | 144 | =item * C - A hash of the method arguments. 145 | 146 | =back 147 | 148 | =cut 149 | 150 | async method call_rpc ($method, %args) { 151 | my $service_name = $myriad->registry->make_service_name($pkg); 152 | await $myriad->rpc_client->call_rpc($service_name, $method, %args); 153 | } 154 | 155 | =head2 add_subscription 156 | 157 | Creats a new subscription in the service. 158 | 159 | This sub takes the source of the data in multiple ways 160 | described in the parameters section, only one of them required. 161 | 162 | =over 4 163 | 164 | =item * C - The channel name that the events will be emitted to. 165 | 166 | =item * C - A perl arrayref that its content is going to be emitted as events. 167 | 168 | =back 169 | 170 | =cut 171 | 172 | method add_subscription ($channel, %args) { 173 | if (my $data = $args{array}) { 174 | my $batch = Sub::Util::set_subname( 175 | $channel, 176 | async sub { 177 | while (my @next = splice($data->@*, 0, 5)) { 178 | return \@next; 179 | } 180 | } 181 | ); 182 | 183 | $meta_service->add_method("batch_$channel", $batch); 184 | apply_subattrs_for_pkg( 185 | $pkg, 186 | Batch => '', 187 | $pkg->can("batch_$channel"), 188 | ); 189 | 190 | $self 191 | } else { 192 | die 'only simple arrays are supported at the moment'; 193 | } 194 | } 195 | 196 | =head2 add_receiver 197 | 198 | Adds a new receiver in the given service. 199 | 200 | =over 4 201 | 202 | =item * C - The source service name. 203 | 204 | =item * C - The source of the events channel name. 205 | 206 | =item * C - A coderef that will handle the events. 207 | 208 | =back 209 | 210 | =cut 211 | 212 | method add_receiver ($from, $channel, $handler) { 213 | my $receiver = Sub::Util::set_subname( 214 | "receiver_$channel", async sub { 215 | my ($self, $src) = @_; 216 | await $src->each($handler)->completed; 217 | } 218 | ); 219 | 220 | $meta_service->add_method("receiver_$channel", $receiver); 221 | apply_subattrs_for_pkg( 222 | $pkg, 223 | Receiver => "(from => '$from', channel => '$channel')", 224 | $pkg->can("receiver_$channel"), 225 | ); 226 | 227 | $self; 228 | } 229 | 230 | 1; 231 | 232 | __END__ 233 | 234 | =head1 AUTHOR 235 | 236 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 237 | 238 | See L for full details. 239 | 240 | =head1 LICENSE 241 | 242 | Copyright Deriv Group Services Ltd 2020. Licensed under the same terms as Perl itself. 243 | 244 | -------------------------------------------------------------------------------- /lib/yriad.pm: -------------------------------------------------------------------------------- 1 | package yriad; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | # VERSION 7 | # AUTHORITY 8 | 9 | 1; 10 | 11 | __END__ 12 | 13 | =head1 AUTHOR 14 | 15 | Deriv Group Services Ltd. C<< DERIV@cpan.org >>. 16 | 17 | See L for full details. 18 | 19 | =head1 LICENSE 20 | 21 | Copyright Deriv Group Services Ltd 2020-2024. Licensed under the same terms as Perl itself. 22 | 23 | -------------------------------------------------------------------------------- /pod-inherit.patch: -------------------------------------------------------------------------------- 1 | --- a/Pod/Inherit.pm 2020-04-03 21:58:36.470197738 +0800 2 | +++ b/Pod/Inherit.pm 2014-06-13 10:45:18.000000000 +0800 3 | @@ -909,7 +909,7 @@ 4 | unless (exists $INC{$class_as_filename}) { 5 | # Still no source? Great... we'll have to pray that require will work... 6 | print "Still no source found for $classname; forced to use 'require'\n" if ($DEBUG && !$src); 7 | - my $did_it = $src ? do $src : Class::Load::load_optional_class($classname); 8 | + my $did_it = $src ? do "./$src" : Class::Load::load_optional_class($classname); 9 | unless ($did_it) { 10 | my $err = $@; 11 | $err =~ s/ \(\@INC contains: .*\)//; 12 | @@ -994,7 +994,10 @@ 13 | $src = Path::Class::File->new($src)->as_foreign('Unix'); 14 | 15 | return <<__END_HEADER__; 16 | +=encoding utf8 17 | + 18 | =for comment POD_DERIVED_INDEX_GENERATED 19 | + 20 | The following documentation is automatically generated. Please do not edit 21 | this file, but rather the original, inline with $classname 22 | at $src 23 | -------------------------------------------------------------------------------- /script/update-cpanfile.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | use strict; 3 | use warnings; 4 | 5 | use feature qw(say); 6 | use Path::Tiny; 7 | use Module::Load; 8 | require V; 9 | 10 | path('cpanfile')->edit_lines_utf8(sub { 11 | if(/^require/) { 12 | my ($module, $version) = /^(?:requires|suggests|recommends)\s+['"]([^'"]+)['"](?:\s*,\s*["']>= ([^'"]+)['"])?/; 13 | $version //= 0; 14 | my $target = V::get_version($module) // do { 15 | Module::Load::load($module); 16 | $module->VERSION 17 | }; 18 | if($version and $target and $version < $target) { 19 | say "Update $module => $version ($target)"; 20 | s{['"]>=\s*\K(?:[^'"]+)(?=\s*['"].*;)}{$target}; 21 | } 22 | } 23 | }); 24 | -------------------------------------------------------------------------------- /t/RPC/full-cycle.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use Test::Fatal; 7 | use Test::Myriad; 8 | use Log::Any::Adapter qw(TAP); 9 | 10 | use Future; 11 | use Future::AsyncAwait; 12 | use Object::Pad; 13 | 14 | my ($ping_service, $pong_service); 15 | 16 | package Test::Ping { 17 | use Myriad::Service; 18 | async method ping : RPC (%args) { 19 | return await $api->service_by_name('Test::Pong')->call_rpc('pong'); 20 | } 21 | async method throws_error : RPC (%args) { 22 | die 'some error here'; 23 | } 24 | } 25 | 26 | package Test::Pong { 27 | use Myriad::Service; 28 | async method pong : RPC (%args) { 29 | return {pong => 1}; 30 | } 31 | } 32 | 33 | BEGIN { 34 | $ping_service = Test::Myriad->add_service(service => 'Test::Ping'); 35 | $pong_service = Test::Myriad->add_service(service => 'Test::Pong'); 36 | } 37 | 38 | 39 | await Test::Myriad->ready(); 40 | 41 | subtest 'RPC should return a response to caller' => sub { 42 | my $response = $pong_service->call_rpc('pong')->get; 43 | cmp_deeply($response, {pong => 1}); 44 | done_testing; 45 | }; 46 | 47 | subtest 'RPC client should receive a response' => sub { 48 | my $response = $ping_service->call_rpc('ping')->get(); 49 | cmp_deeply($response, {pong => 1}); 50 | done_testing; 51 | }; 52 | 53 | subtest 'Methods which throw errors should raise an exception in the caller too' => sub { 54 | my $ex = exception { 55 | my $response = $ping_service->call_rpc('throws_error')->get(); 56 | note explain $response; 57 | }; 58 | isa_ok($ex, 'Myriad::Exception::InternalError'); 59 | like($ex->reason->{reason}, qr/some error here/, 'exception had original message'); 60 | done_testing; 61 | }; 62 | 63 | done_testing; 64 | 65 | -------------------------------------------------------------------------------- /t/RPC/memory.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Ryu::Async; 5 | use IO::Async::Loop; 6 | use Future::AsyncAwait; 7 | 8 | use Test::More; 9 | use Test::MemoryGrowth; 10 | 11 | use Syntax::Keyword::Try; 12 | use Log::Any qw($log); 13 | use Log::Any::Adapter qw(Stderr), log_level => 'info'; 14 | 15 | # Myriad::RPC should be included to load exceptions 16 | use Myriad::RPC; 17 | use Myriad::Transport::Memory; 18 | use Myriad::RPC::Implementation::Memory; 19 | 20 | my $loop = IO::Async::Loop->new; 21 | 22 | my $message_args = { 23 | rpc => 'test', 24 | message_id => 1, 25 | who => 'client', 26 | deadline => time, 27 | args => '{}', 28 | stash => '{}', 29 | trace => '{}' 30 | }; 31 | 32 | $loop->add(my $ryu = Ryu::Async->new); 33 | $loop->add(my $transport = Myriad::Transport::Memory->new()); 34 | $loop->add(my $rpc = Myriad::RPC::Implementation::Memory->new(transport => $transport)); 35 | 36 | isa_ok($rpc, 'IO::Async::Notifier'); 37 | 38 | my $sink = $ryu->sink(label=> 'rpc::test'); 39 | 40 | $sink->source->map(async sub { 41 | await $rpc->reply_success('test::service', shift, {ok => 1}); 42 | })->resolve()->completed->retain(); 43 | 44 | $rpc->create_from_sink(method => 'test', sink => $sink, service => 'test.service'); 45 | $rpc->start->retain->on_fail(sub { 46 | die shift; 47 | }); 48 | 49 | subtest 'it should propagate the message correctly' => sub { 50 | (async sub { 51 | $message_args->{rpc} = 'test'; 52 | 53 | my $sub = await $transport->subscribe('client'); 54 | my $id = await $transport->add_to_stream('service.test.service.rpc/test', $message_args->%*); 55 | await $sub->take(1)->each(sub { 56 | my $message = shift; 57 | like($message, qr{\\"ok\\":1}, 'message has been propagated correctly'); 58 | })->completed; 59 | })->()->get; 60 | }; 61 | 62 | subtest 'it should shutdown cleanly' => sub { 63 | (async sub { 64 | my $f = await $rpc->stop; 65 | ok($f, 'it should stop'); 66 | })->()->get(); 67 | }; 68 | 69 | done_testing; 70 | 71 | -------------------------------------------------------------------------------- /t/RPC/message.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use JSON::MaybeUTF8 qw(encode_json_utf8); 5 | 6 | use Test::More; 7 | use Test::Fatal; 8 | use Test::MemoryGrowth; 9 | 10 | use Storable qw(dclone); 11 | # Myriad::RPC should be included to load exceptions. 12 | use Myriad::RPC; 13 | use Myriad::RPC::Message; 14 | 15 | my $message_args = { 16 | rpc => 'test', 17 | message_id => 1, 18 | who => 'client', 19 | deadline => time, 20 | args => '{}', 21 | stash => '{}', 22 | trace => '{}' 23 | }; 24 | 25 | is(exception { 26 | Myriad::RPC::Message->new(%$message_args) 27 | }, undef, "->from_hash with correct params should succeed"); 28 | 29 | for my $key (qw/rpc message_id who deadline args/) { 30 | like(exception { 31 | my $args = dclone $message_args; 32 | delete $args->{$key}; 33 | Myriad::RPC::Message::from_hash(%$args); 34 | my $json = encode_json_utf8($message_args); 35 | Myriad::RPC::Message::from_json($json) 36 | }, qr{^Invalid request.*}, "->from_* without $key should not succeed"); 37 | } 38 | 39 | my $message = Myriad::RPC::Message::from_hash(%$message_args); 40 | is(exception { 41 | $message->as_json(); 42 | $message->as_hash(); 43 | }, undef, '->as_* should succeed'); 44 | 45 | # Deadline check 46 | 47 | $message_args->{deadline} = time + 30; 48 | my $valid_message = Myriad::RPC::Message::from_hash($message_args->%*); 49 | 50 | cmp_ok($valid_message->passed_deadline, '==', 0, 'Message did not pass deadline'); 51 | 52 | $message_args->{deadline} = time - 1; 53 | my $invalid_message = Myriad::RPC::Message::from_hash($message_args->%*); 54 | 55 | cmp_ok($invalid_message->passed_deadline, '==', 1, 'Message passed the deadline'); 56 | 57 | 58 | no_growth { 59 | my $message = Myriad::RPC::Message::from_hash(%$message_args); 60 | } 'no memory leak detected'; 61 | 62 | done_testing; 63 | -------------------------------------------------------------------------------- /t/RPC/multiple-rpcs.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | use Future; 7 | use Future::AsyncAwait; 8 | use Future::Utils qw(fmap_void); 9 | 10 | use Myriad; 11 | 12 | package Service::RPC { 13 | use Myriad::Service; 14 | 15 | async method echo : RPC (%args) { 16 | return \%args; 17 | } 18 | 19 | async method ping : RPC (%args) { 20 | return {time => time} 21 | } 22 | 23 | async method reverse : RPC (%args) { 24 | return {reversed => scalar reverse("$args{v}")}; 25 | } 26 | }; 27 | 28 | 29 | subtest 'RPCs should not block each others in the same service' => sub { 30 | (async sub { 31 | my $myriad = new_ok('Myriad'); 32 | 33 | await $myriad->configure_from_argv('--transport', $ENV{MYRIAD_TRANSPORT} // 'memory', '--transport_cluster', $ENV{MYRIAD_TRANSPORT_CLUSTER} // 0); 34 | await $myriad->add_service('Service::RPC'); 35 | 36 | # Run the service 37 | $myriad->run->retain->on_fail(sub { 38 | die shift; 39 | }); 40 | await $myriad->loop->delay_future(after => 0.25); 41 | 42 | # if one RPC doesn't have messages it should not block the others 43 | for my $i (0..10) { 44 | await Future->needs_any( 45 | fmap_void(async sub { 46 | my $rpc = shift; 47 | my $response = await $myriad->rpc_client->call_rpc('service.rpc', $rpc)->catch(sub {warn shift}); 48 | if ( $rpc eq 'ping' ) { 49 | cmp_ok $response->{time}, '==', time, 'Ping Matching Time'; 50 | } elsif ( $rpc eq 'echo' ) { 51 | like $response, qr//, 'Got echo response'; 52 | } 53 | }, foreach => ['echo', 'ping'], concurrent => 3), 54 | $myriad->loop->timeout_future(after => 1) 55 | ); 56 | } 57 | })->()->get(); 58 | }; 59 | 60 | subtest 'RPCs should not block each others in different services, same Myriad instance' => sub { 61 | (async sub { 62 | 63 | package Another::RPC { 64 | use Myriad::Service; 65 | 66 | async method zero : RPC (%args) { 67 | return 0; 68 | } 69 | 70 | async method five : RPC (%args) { 71 | return 5; 72 | } 73 | 74 | async method twenty_five : RPC (%args) { 75 | return 25; 76 | } 77 | 78 | async method double : RPC (%args) { 79 | return $args{v} * 2; 80 | } 81 | }; 82 | 83 | my $myriad = new_ok('Myriad'); 84 | 85 | await $myriad->configure_from_argv('--transport', $ENV{MYRIAD_TRANSPORT} // 'memory', '--transport_cluster', $ENV{MYRIAD_TRANSPORT_CLUSTER} // 0); 86 | await $myriad->add_service('Service::RPC'); 87 | await $myriad->add_service('Another::RPC'); 88 | 89 | # Run the service 90 | $myriad->run->retain->on_fail(sub { 91 | die shift; 92 | }); 93 | await $myriad->loop->delay_future(after => 0.25); 94 | 95 | # if one service's RPC doesn't have messages it should not block the others 96 | 97 | for my $i (0..10) { 98 | await Future->needs_any( 99 | fmap_void(async sub { 100 | my ($service, $rpc, $args, $res) = shift->@*; 101 | my $response = await $myriad->rpc_client->call_rpc($service, $rpc, %$args); 102 | is_deeply $response, $res, "Matching response $service:$rpc"; 103 | }, foreach => [ 104 | ['service.rpc' => 'echo' , { hi => 'echo' } , { hi => 'echo' } ], 105 | ['service.rpc' => 'reverse', { v => 'reverseme' }, { reversed => 'emesrever' } ], 106 | ['another.rpc' => 'double' , { v => 4 } , 8 ], 107 | ['another.rpc' => 'five' , {} , 5 ], 108 | ], concurrent => 6), 109 | $myriad->loop->timeout_future(after => 1), 110 | ); 111 | # Calling ping RPC here where it return time is inefficient as we might go to the next second. 112 | } 113 | })->()->get(); 114 | }; 115 | 116 | done_testing(); 117 | -------------------------------------------------------------------------------- /t/RPC/overflow-protection.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::MockModule; 6 | 7 | use Future; 8 | use Future::AsyncAwait; 9 | use Future::Utils qw(fmap_void); 10 | use IO::Async::Loop; 11 | use Myriad::Transport::Memory; 12 | use Myriad::Transport::Redis; 13 | use Myriad::RPC::Message; 14 | use Sys::Hostname qw(hostname); 15 | use Object::Pad qw(:experimental(mop)); 16 | 17 | use Myriad; 18 | 19 | my $processed = 0; 20 | 21 | package Service::RPC { 22 | use Myriad::Service; 23 | field $count; 24 | 25 | async method startup () { 26 | # Zero our counter on startup 27 | $count = 0; 28 | } 29 | 30 | async method never_ending_rpc : RPC (%args) { 31 | ++$count; 32 | 33 | $args{internal_count} = $count; 34 | $log->tracef('DOING %s', \%args); 35 | $processed++; 36 | await $self->loop->delay_future(after => 1000); 37 | return \%args; 38 | } 39 | }; 40 | 41 | my $loop = IO::Async::Loop->new; 42 | # Only used for in memory tests 43 | my $transport; 44 | async sub myriad_instance { 45 | my $service = shift // ''; 46 | 47 | my $myriad = new_ok('Myriad'); 48 | 49 | # Only in case of memory transport, we want to share the same transport instance. 50 | if (!$ENV{MYRIAD_TRANSPORT} || $ENV{MYRIAD_TRANSPORT} eq 'memory' ) { 51 | my $metaclass = Object::Pad::MOP::Class->for_class('Myriad'); 52 | $metaclass->get_field('$memory_transport')->value($myriad) = $transport; 53 | } 54 | 55 | my @config = ('--transport', $ENV{MYRIAD_TRANSPORT} // 'memory', '--transport_cluster', $ENV{MYRIAD_TRANSPORT_CLUSTER} // 0); 56 | push @config, qw(--log_level warn); 57 | await $myriad->configure_from_argv(@config, $service); 58 | $myriad->run->retain->on_fail(sub { fail(shift); }); 59 | 60 | return $myriad; 61 | 62 | } 63 | 64 | my $whoami = Myriad::Util::UUID::uuid(); 65 | sub generate_requests { 66 | my ($rpc, $count, $expiry) = @_; 67 | my $id = 1; 68 | my @req; 69 | for (1..$count) { 70 | push @req, Myriad::RPC::Message->new( 71 | rpc => $rpc, 72 | who => $whoami, 73 | deadline => time + $expiry, 74 | message_id => $id, 75 | args => { 76 | test => $id++, 77 | who => $whoami 78 | } 79 | ); 80 | } 81 | return @req; 82 | } 83 | 84 | subtest 'RPCs should not consume more than it can process' => sub { 85 | (async sub { 86 | 87 | my $message_count = 55; 88 | my @requests = generate_requests('never_ending_rpc', $message_count, 1000); 89 | my $stream_name = 'service.service.rpc.rpc/never_ending_rpc'; 90 | 91 | # Add messages to stream then read them without acknowleging to make them go into pending state 92 | if (!$ENV{MYRIAD_TRANSPORT} || $ENV{MYRIAD_TRANSPORT} eq 'memory' ) { 93 | $transport = Myriad::Transport::Memory->new; 94 | $loop->add($transport); 95 | foreach my $req (@requests) { 96 | await $transport->add_to_stream($stream_name, $req->as_hash->%*); 97 | } 98 | await $transport->create_consumer_group($stream_name, 'processors'); 99 | await $transport->read_from_stream_by_consumer($stream_name, 'processors', hostname()); 100 | } else { 101 | $loop->add( my $redis = Myriad::Transport::Redis->new( 102 | redis_uri => $ENV{MYRIAD_TRANSPORT}, 103 | cluster => $ENV{MYRIAD_TRANSPORT_CLUSTER} // 0, 104 | )); 105 | await $redis->start; 106 | foreach my $req (@requests) { 107 | await $redis->xadd($stream_name => '*', $req->as_hash->%*); 108 | } 109 | await $redis->create_group($stream_name, 'processors'); 110 | await $redis->read_from_stream(client => hostname(), group => 'processors', stream => $stream_name); 111 | } 112 | 113 | 114 | note "starting service"; 115 | my $rpc_myriad = await myriad_instance('Service::RPC'); 116 | await $loop->delay_future(after => 0.4); 117 | 118 | is $processed, 50, 'Have tried to process only what it can take'; 119 | isnt $processed, $message_count, 'messages sent count is not matching messages tried to process count'; 120 | })->()->get(); 121 | }; 122 | 123 | 124 | done_testing(); 125 | -------------------------------------------------------------------------------- /t/RPC/pending-requests.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::MockModule; 6 | 7 | use Future; 8 | use Future::AsyncAwait; 9 | use Future::Utils qw(fmap_void); 10 | use IO::Async::Loop; 11 | use Myriad::Transport::Memory; 12 | use Myriad::Transport::Redis; 13 | use Myriad::RPC::Message; 14 | use Sys::Hostname qw(hostname); 15 | use Object::Pad qw(:experimental(mop)); 16 | 17 | use Myriad; 18 | 19 | my $processed = 0; 20 | 21 | package Service::RPC { 22 | use Myriad::Service; 23 | field $count; 24 | 25 | async method startup () { 26 | # Zero our counter on startup 27 | $count = 0; 28 | } 29 | 30 | async method controlled_rpc : RPC (%args) { 31 | ++$count; 32 | 33 | $args{internal_count} = $count; 34 | $log->tracef('DOING %s', \%args); 35 | $processed++; 36 | return \%args; 37 | } 38 | }; 39 | 40 | my $loop = IO::Async::Loop->new; 41 | # Only used for in memory tests 42 | my $transport; 43 | async sub myriad_instance { 44 | my $service = shift // ''; 45 | 46 | my $myriad = new_ok('Myriad'); 47 | 48 | # Only in case of memory transport, we want to share the same transport instance. 49 | if (!$ENV{MYRIAD_TRANSPORT} || $ENV{MYRIAD_TRANSPORT} eq 'memory' ) { 50 | my $metaclass = Object::Pad::MOP::Class->for_class('Myriad'); 51 | $metaclass->get_field('$memory_transport')->value($myriad) = $transport; 52 | } 53 | 54 | my @config = ('--transport', $ENV{MYRIAD_TRANSPORT} // 'memory', '--transport_cluster', $ENV{MYRIAD_TRANSPORT_CLUSTER} // 0, '-l', 'debug'); 55 | push @config, qw(--log_level warn); 56 | await $myriad->configure_from_argv(@config, $service); 57 | $myriad->run->retain->on_fail(sub { die shift; }); 58 | 59 | return $myriad; 60 | 61 | } 62 | 63 | my $whoami = Myriad::Util::UUID::uuid(); 64 | sub generate_requests { 65 | my ($rpc, $count, $expiry) = @_; 66 | my $id = 1; 67 | my @req; 68 | for (1..$count) { 69 | push @req, Myriad::RPC::Message->new( 70 | rpc => $rpc, 71 | who => $whoami, 72 | deadline => time + $expiry, 73 | message_id => $id, 74 | args => {test => $id++, who => $whoami } 75 | ); 76 | } 77 | return @req; 78 | } 79 | 80 | subtest 'RPCs on start should check and process pending messages on start' => sub { 81 | (async sub { 82 | 83 | my $message_count = 20; 84 | my @requests = generate_requests('controlled_rpc', $message_count, 1000); 85 | my $stream_name = 'service.service.rpc.rpc/controlled_rpc'; 86 | 87 | # Add messages to stream then read them without acknowleging to make them go into pending state 88 | if (!$ENV{MYRIAD_TRANSPORT} || $ENV{MYRIAD_TRANSPORT} eq 'memory' ) { 89 | $transport = Myriad::Transport::Memory->new; 90 | $loop->add($transport); 91 | foreach my $req (@requests) { 92 | await $transport->add_to_stream($stream_name, $req->as_hash->%*); 93 | } 94 | await $transport->create_consumer_group($stream_name, 'processors'); 95 | await $transport->read_from_stream_by_consumer($stream_name, 'processors', hostname()); 96 | } else { 97 | $loop->add( my $redis = Myriad::Transport::Redis->new( 98 | redis_uri => $ENV{MYRIAD_TRANSPORT}, 99 | cluster => $ENV{MYRIAD_TRANSPORT_CLUSTER} // 0, 100 | )); 101 | await $redis->start; 102 | foreach my $req (@requests) { 103 | await $redis->xadd($stream_name => '*', $req->as_hash->%*); 104 | } 105 | await $redis->create_group($stream_name, 'processors'); 106 | await $redis->read_from_stream(client => hostname(), group => 'processors', stream => $stream_name); 107 | } 108 | 109 | 110 | note "starting service"; 111 | my $rpc_myriad = await myriad_instance('Service::RPC'); 112 | await $loop->delay_future(after => 0.4); 113 | 114 | is $processed, $message_count, 'Have processed all messages'; 115 | })->()->get(); 116 | }; 117 | 118 | 119 | done_testing(); 120 | -------------------------------------------------------------------------------- /t/Subscription/full-cycle.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Future::AsyncAwait; 5 | use Test::More; 6 | use Log::Any::Adapter qw(TAP); 7 | use Myriad; 8 | 9 | package Example::Sender { 10 | use Myriad::Service; 11 | field $sent = 0; 12 | 13 | async method simple_emitter : Emitter() ($sink) { 14 | my $data = {event => 1}; 15 | $log->infof('emitter emits %s', $data); 16 | $sink->emit($data); 17 | } 18 | 19 | async method simple_batch : Batch () { 20 | my $arr = []; 21 | $arr = [{event => 1}, {event => 2}] unless $sent; 22 | $sent = 1; 23 | $log->infof('batch emits %s', $arr); 24 | return $arr; 25 | } 26 | } 27 | 28 | my @received_from_emitter; 29 | my @received_from_batch; 30 | 31 | package Example::Receiver { 32 | use Myriad::Service; 33 | async method receiver_from_emitter : Receiver( 34 | service => 'Example::Sender', 35 | channel => 'simple_emitter' 36 | ) ($src) { 37 | return $src->map(sub { 38 | push @received_from_emitter, shift 39 | }); 40 | } 41 | 42 | async method receiver_from_batch : Receiver( 43 | service => 'Example::Sender', 44 | channel => 'simple_batch' 45 | ) ($src) { 46 | return $src->map(sub { 47 | $log->infof('batch receives %s', $_); 48 | push @received_from_batch, shift 49 | }); 50 | } 51 | } 52 | 53 | my $myriad = new_ok('Myriad'); 54 | await $myriad->configure_from_argv( 55 | qw(--transport memory --log_level warn service) 56 | ); 57 | 58 | await $myriad->add_service('Example::Receiver'); 59 | await $myriad->add_service('Example::Sender'); 60 | 61 | $myriad->run->retain; 62 | 63 | ok($myriad->subscription, 'subscription is initiated'); 64 | 65 | is(scalar $myriad->subscription->receivers->@*, 2, 'We have correct number of receivers detected'); 66 | 67 | # we need 4 steps to publish the events 68 | $myriad->loop->loop_once for 0..4; 69 | 70 | is(@received_from_emitter, 1, 'we have received correct number of messages from emitter'); 71 | is(@received_from_batch, 2, 'we have received correct number of messages from batch'); 72 | 73 | done_testing; 74 | 75 | -------------------------------------------------------------------------------- /t/Subscription/multi-sub.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Future::AsyncAwait; 5 | use Test::More; 6 | use Log::Any::Adapter qw(TAP); 7 | use Myriad; 8 | 9 | package Example::Sender { 10 | use Myriad::Service; 11 | 12 | async method fast_e : Emitter() ($sink) { 13 | my $count = 1; 14 | while (1) { 15 | await $self->loop->delay_future(after => 0.2); 16 | $sink->emit({event => $count++}); 17 | } 18 | } 19 | 20 | async method med_e : Emitter() ($sink) { 21 | my $count = 1; 22 | while (1) { 23 | await $self->loop->delay_future(after => 1 * $count); 24 | $sink->emit({event => $count++}); 25 | } 26 | } 27 | 28 | async method slow_e : Emitter() ($sink) { 29 | my $count = 1; 30 | while (1) { 31 | await $self->loop->delay_future(after => 1 * 3 * $count); 32 | $sink->emit({event => $count++}); 33 | } 34 | } 35 | 36 | async method fast_e2 : Emitter() ($sink) { 37 | my $count = 1; 38 | while (1) { 39 | await $self->loop->delay_future(after => 0.2); 40 | $sink->emit({event => $count++}); 41 | } 42 | } 43 | } 44 | 45 | package Example::Sender2 { 46 | 47 | use Myriad::Service; 48 | 49 | async method em : Emitter() ($sink) { 50 | my $count = 1; 51 | while (1) { 52 | await $self->loop->delay_future(after => 1 * 0.5 * $count); 53 | $sink->emit({event => $count++}); 54 | } 55 | } 56 | 57 | async method never_e : Emitter() ($sink) { 58 | my $count = 1; 59 | while (1) { 60 | await $self->loop->delay_future(after => 10); 61 | # 62 | } 63 | } 64 | } 65 | my %received; 66 | 67 | package Example::Receiver { 68 | use Myriad::Service; 69 | async method zreceiver_from_emitter2 : Receiver( 70 | service => 'Example::Sender', 71 | channel => 'fast_e' 72 | ) ($src) { 73 | return $src->map(sub { 74 | push @{$received{fast_e}}, shift 75 | }); 76 | } 77 | 78 | async method receiver_from_emitter : Receiver( 79 | service => 'Example::Sender', 80 | channel => 'med_e' 81 | ) ($src) { 82 | return $src->map(sub { 83 | push @{$received{med_e}}, shift 84 | }); 85 | } 86 | 87 | async method hreceiver_from_emitter : Receiver( 88 | service => 'Example::Sender2', 89 | channel => 'em' 90 | ) ($src) { 91 | return $src->map(sub { 92 | push @{$received{em}}, shift 93 | }); 94 | } 95 | 96 | async method receiver_from_emitter3 : Receiver( 97 | service => 'Example::Sender', 98 | channel => 'slow_e' 99 | ) ($src) { 100 | return $src->map(sub { 101 | push @{$received{slow_e}}, shift 102 | }); 103 | } 104 | 105 | async method receiver_from_emitter4 : Receiver( 106 | service => 'Example::Sender', 107 | channel => 'fast_e2' 108 | ) ($src) { 109 | return $src->map(sub { 110 | push @{$received{fast_e2}}, shift 111 | }); 112 | } 113 | 114 | async method never_receive : Receiver( 115 | service => 'Example::Sender2', 116 | channel => 'never_e' 117 | ) ($src) { 118 | return $src->map(sub { 119 | push @{$received{never_e}}, shift 120 | }); 121 | } 122 | } 123 | 124 | my $myriad = new_ok('Myriad'); 125 | my @arg; 126 | my $empty_stream_name; 127 | if (my $t = $ENV{MYRIAD_TEST_TRANSPORT}) { 128 | @arg = qw(--transport redis://redis-node-0:6379 --transport_cluster 1 --log_level warn service); 129 | $empty_stream_name = 'service.subscriptions.example.sender2/never_e'; 130 | } else { 131 | @arg = qw(--transport memory --log_level warn service); 132 | $empty_stream_name = 'example.sender2.never_e'; 133 | } 134 | 135 | await $myriad->configure_from_argv(@arg); 136 | 137 | await $myriad->add_service('Example::Receiver'); 138 | await $myriad->add_service('Example::Sender2'); 139 | await $myriad->add_service('Example::Sender'); 140 | 141 | $myriad->run->retain; 142 | 143 | ok($myriad->subscription, 'subscription is initiated'); 144 | 145 | my $loop = IO::Async::Loop->new; 146 | await $loop->delay_future(after => 3.2); 147 | my $transport = $myriad->transport('subscription'); 148 | 149 | is scalar $received{fast_e}->@*, 15, 'Got the right number of events from fast_emitter'; 150 | is scalar $received{med_e}->@*, 2, 'Got the right number of events from medium_emitter'; 151 | is scalar $received{slow_e}->@*, 1, 'Got the right number of events from slow_emitter'; 152 | is scalar $received{fast_e2}->@*, 15, 'Got the right number of events from fast_emitter2'; 153 | is scalar $received{em}->@*, 3, 'Got the right number of events from secondary medium_emitter'; 154 | is scalar $received{never_e}->@*, 0, 'Got no events from never_emit'; 155 | 156 | my $info = await $transport->stream_info($empty_stream_name); 157 | ok($info, 'Stream has been created for the never-published emitter'); 158 | 159 | # Give any pending events a chance to complete, e.g. metrics 160 | await $loop->later; 161 | 162 | done_testing; 163 | 164 | -------------------------------------------------------------------------------- /t/Subscription/transport-relation.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Future::AsyncAwait; 5 | 6 | use Test::More; 7 | use Test::Myriad; 8 | 9 | package Test::Emitter { 10 | use Myriad::Service; 11 | async method just_emitter :Emitter() ($sink) { 12 | my $i = 0; 13 | while (1) { 14 | $sink->emit({event => $i++}); 15 | await $self->loop->delay_future(after => 0.001); 16 | } 17 | } 18 | } 19 | 20 | package Test::Receiver { 21 | use Myriad::Service; 22 | async method just_receiver :Receiver( 23 | service => 'Test::Emitter', 24 | channel => 'just_emitter' 25 | ) ($src) { 26 | return $src->map(sub {}); 27 | } 28 | } 29 | 30 | BEGIN { 31 | Test::Myriad->add_service(service => 'Test::Emitter'); 32 | Test::Myriad->add_service(service => 'Test::Receiver'); 33 | } 34 | 35 | await Test::Myriad->ready(); 36 | 37 | my $myriad = Test::Myriad->instance; 38 | 39 | subtest 'Consumer groups usage' => sub { 40 | my $transport = $myriad->transport('subscription'); 41 | my $stream = 'test.emitter.just_emitter'; 42 | ok($transport->exists($stream)->get, 'stream exists'); 43 | my $groups = $transport->stream_groups_info($stream)->get; 44 | is ($groups->[0]->{name}, 'test.receiver', 'correct group name'); 45 | }; 46 | 47 | done_testing; 48 | 49 | -------------------------------------------------------------------------------- /t/batch.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | use Ryu::Async; 7 | 8 | use IO::Async::Loop; 9 | use Future::AsyncAwait; 10 | 11 | use Myriad::Service::Implementation; 12 | 13 | my $loop = IO::Async::Loop->new(); 14 | 15 | $loop->add(my $ryu = Ryu::Async->new); 16 | 17 | subtest 'batch should work fine' => sub { 18 | my $fake_service = Myriad::Service::Implementation->new( 19 | name => 'fake_instance', 20 | ); 21 | $loop->add($fake_service); 22 | 23 | my $sink = $ryu->sink; 24 | $fake_service->process_batch('fake_batch', async sub { 25 | return [{key => 1}]; 26 | }, $sink)->retain; 27 | 28 | (async sub { 29 | $loop->delay_future(after => 0.001)->then(sub { 30 | $sink->source->finish; 31 | })->retain; 32 | 33 | my @batch = await $sink->source->as_list; 34 | 35 | cmp_ok(@batch, '>=', 1, 'batch working correctly'); 36 | 37 | })->()->get() 38 | 39 | }; 40 | 41 | 42 | subtest 'batch should through if output is wrong' => sub { 43 | my $fake_service = Myriad::Service::Implementation->new( 44 | name => 'fake_instance', 45 | ); 46 | 47 | $loop->add($fake_service); 48 | 49 | my $sink = $ryu->sink; 50 | like( 51 | exception { $fake_service->process_batch('fake_batch', async sub { 52 | return {key => 1}; 53 | }, $sink)->get}, 54 | qr/Batch should return an arrayref/, 'Batch should throw if single hash returned'); 55 | 56 | like( 57 | exception { $fake_service->process_batch('fake_batch', async sub { 58 | return 1; 59 | }, $sink)->get}, 60 | qr/Batch should return an arrayref/, 'Batch should throw if a scalar returned'); 61 | }; 62 | 63 | subtest 'batch should still work if empty array returned' => sub { 64 | my $fake_service = Myriad::Service::Implementation->new( 65 | name => 'fake_instance', 66 | ); 67 | 68 | $loop->add($fake_service); 69 | 70 | my $sink = $ryu->sink; 71 | $fake_service->process_batch('fake_batch', async sub { 72 | return []; 73 | }, $sink)->retain(); 74 | 75 | (async sub { 76 | $loop->delay_future(after => 0.001)->then(sub { 77 | $sink->source->finish; 78 | })->retain; 79 | 80 | my @batch = await $sink->source->as_list; 81 | 82 | cmp_ok(@batch, '==', 0, 'batch did not die'); 83 | })->()->get(); 84 | }; 85 | 86 | done_testing; 87 | 88 | -------------------------------------------------------------------------------- /t/bootstrap.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | # We deliberately *avoid* Test::More here, because it pulls in 5 | # an ever-changing kitchen sync full of awesomely-useful modules 6 | # that will mess up our clean-namespace requirement 7 | 8 | use Myriad::Bootstrap; 9 | 10 | # We cannot call ->autoflush directly, since that'll pull in 10+ extra modules 11 | { 12 | my $oldfh = select(STDOUT); 13 | $| = 1; 14 | select($oldfh); 15 | } 16 | 17 | eval { 18 | Myriad::Bootstrap->boot(sub { 19 | # Must *not* happen at compiletime, hence the require/import 20 | require Test::More; 21 | Test::More->import; 22 | pass('bootstrap success'); 23 | done_testing(); 24 | }); 25 | 1; 26 | } or do { 27 | if ($@ =~ q{Can't locate Linux/Inotify2.pm}) { 28 | print "1..0 # SKIP Linux::Inotify2 not installed\n"; 29 | } else { 30 | print "not ok - exception on ->boot, $@\n"; 31 | print "1..1\n"; 32 | } 33 | }; 34 | -------------------------------------------------------------------------------- /t/class.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | is(exception { 8 | eval <<'EOS' or die $@; 9 | package Example::Class; 10 | use Myriad::Class; 11 | field $something; 12 | method example { $self } 13 | 1 14 | EOS 15 | }, undef, 'can create a class'); 16 | my $obj = new_ok('Example::Class'); 17 | is($obj->example, $obj, 'can call a method'); 18 | 19 | done_testing; 20 | 21 | 22 | -------------------------------------------------------------------------------- /t/commands.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::MockModule; 6 | use Test::MockObject; 7 | use Test::Fatal; 8 | use Test::Deep; 9 | 10 | use Object::Pad qw(:experimental(mop)); 11 | use Log::Any::Adapter qw(TAP); 12 | 13 | use Future::AsyncAwait; 14 | use IO::Async::Loop; 15 | use IO::Async::Test; 16 | 17 | use Myriad; 18 | use Myriad::Commands; 19 | use Myriad::Config; 20 | use Test::Myriad; 21 | 22 | BEGIN { 23 | # if we want to fully test the command 24 | # we should be able to run mock service with a testing RPC 25 | # then call it with the command and test it. 26 | # This will be used in a different flow.t test 27 | Test::Myriad->add_service(name => "Test::Service::Mocked")->add_rpc('test_cmd', success => 1); 28 | } 29 | 30 | $ENV{MYRIAD_TRANSPORT} ||= 'memory'; 31 | my $loop = IO::Async::Loop->new; 32 | testing_loop($loop); 33 | 34 | subtest "service command" => sub { 35 | # Myriad module is required for Command creation but only used in Service command 36 | my $myriad_module = Test::MockModule->new('Myriad'); 37 | my ( @added_services_modules, @add_services_by_name ); 38 | $myriad_module->mock('add_service', async sub { 39 | my ($self, $module, %args) = @_; 40 | # Calling of this sub means Service command has been executed succesfully 41 | push @added_services_modules, $module; 42 | push @add_services_by_name, $args{'name'} if exists $args{'name'}; 43 | }); 44 | 45 | # Fake existence of two sibling modules 46 | { 47 | package Ta::Sibling1; 48 | { 49 | no strict 'refs'; 50 | push @{Ta::Sibling1::ISA}, 'Myriad::Service'; 51 | } 52 | sub new { } 53 | } 54 | { 55 | package Ta::Sibling2; 56 | push @{Ta::Sibling2::ISA}, 'Myriad::Service'; 57 | sub new { } 58 | } 59 | 60 | { 61 | package Ta::Sibling3; 62 | sub new { } 63 | } 64 | 65 | $INC{'Ta/Sibling1.pm'} = 1; 66 | $INC{'Ta/Sibling2.pm'} = 1; 67 | $INC{'Ta/Sibling3.pm'} = 1; 68 | ###### 69 | 70 | my $metaclass = Object::Pad::MOP::Class->for_class('Myriad'); 71 | 72 | my $myriad = Myriad->new; 73 | my $command = new_ok('Myriad::Commands'=> ['myriad', $myriad]); 74 | $metaclass->get_field('$config')->value($myriad) = Myriad::Config->new(); 75 | 76 | # Wrong Service(module) name 77 | like( exception { wait_for_future( $command->service('Ta-wrong') )->get } , qr/unsupported/, 'Died when passing wrong format name'); 78 | like( exception { wait_for_future( $command->service('Ta_wrong') )->get } , qr/not found/, 'Died when passing module that does not exist'); 79 | 80 | # Running multiple services 81 | wait_for_future( $command->service('Ta::')->get->{code}->() )->get; 82 | cmp_deeply(\@added_services_modules, ['Ta::Sibling1', 'Ta::Sibling2'], 'Added both modules'); 83 | # Clear it for next test. 84 | @added_services_modules = (); 85 | 86 | # Running services under the same namespace 87 | wait_for_future( $command->service('Ta::*')->get->{code}->() )->get; 88 | cmp_deeply(\@added_services_modules, ['Ta::Sibling1', 'Ta::Sibling2'], 'Added modules under the namespace'); 89 | # Clear it for next test. 90 | @added_services_modules = (); 91 | 92 | done_testing; 93 | }; 94 | 95 | my $myriad_mod = Test::MockModule->new('Myriad'); 96 | 97 | # Mock shutdown behaviour 98 | # As some commands are expected to call shutdown on completion. 99 | my $shutdown_count = 0; 100 | $myriad_mod->mock('shutdown', async sub { 101 | my $self = shift; 102 | my $shutdown_f = $loop->new_future(label => 'shutdown future'); 103 | $shutdown_count++; 104 | $shutdown_f->done('shutdown called'); 105 | }); 106 | my $rmt_svc_cmd_called; 107 | my $test_cmd; 108 | my %calls; 109 | my %started_components; 110 | 111 | sub mock_component { 112 | my ($component, $cmd, $test_name) = @_; 113 | 114 | $test_cmd = $test_name; 115 | %calls = (); 116 | $rmt_svc_cmd_called = {}; 117 | %started_components = (); 118 | $myriad_mod->mock($component, sub { 119 | my ($self) = @_; 120 | my $mock = Test::MockObject->new(); 121 | $mock->mock( $cmd, async sub { 122 | my ($self, $service_name, $rpc, %args) = @_; 123 | $rmt_svc_cmd_called->{$cmd} //= []; 124 | push @{$rmt_svc_cmd_called->{$cmd}}, {svc => $service_name, rpc => $rpc, args => \%args}; 125 | $calls{$rpc}++; 126 | return {success => 1}; 127 | }); 128 | my $f; 129 | $mock->mock('start', async sub { 130 | my ($self) = @_; 131 | $f //= $loop->new_future; 132 | $started_components{$component} = 1; 133 | return $f; 134 | }); 135 | 136 | $mock->mock('create_from_sink', async sub {}); 137 | return $mock; 138 | }); 139 | 140 | } 141 | 142 | done_testing; 143 | -------------------------------------------------------------------------------- /t/config.yml: -------------------------------------------------------------------------------- 1 | transport: value_from_file 2 | 3 | services: 4 | fake.name: 5 | config: 6 | key: value from file 7 | instance: 8 | demo: 9 | config: 10 | key: instance value from file 11 | 12 | -------------------------------------------------------------------------------- /t/defer-attrib.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Log::Any::Adapter qw(TAP); 5 | 6 | # Enforce some level of delay 7 | BEGIN { $ENV{MYRIAD_RANDOM_DELAY} = 0.005 } 8 | 9 | use Test::More; 10 | use Test::Deep; 11 | 12 | use Object::Pad; 13 | use Future::AsyncAwait; 14 | use IO::Async::Loop; 15 | 16 | class Example :isa(IO::Async::Notifier) { 17 | use Myriad::Util::Defer; 18 | use Log::Any qw($log); 19 | 20 | async method run : Defer (%args) { 21 | $log->tracef("in async method run"); 22 | await $self->loop->delay_future(after => 0.002); 23 | $log->tracef("after async method resumed"); 24 | return \%args; 25 | } 26 | 27 | async method immediate { 28 | return 1; 29 | } 30 | 31 | async method immediate_deferred : Defer { 32 | $log->tracef('in immediate_deferred'); 33 | return 1; 34 | } 35 | } 36 | 37 | my $loop = IO::Async::Loop->new; 38 | $loop->add(my $example = Example->new); 39 | is_deeply( 40 | $example->run(x => 123)->get, 41 | { x => 123}, 42 | 'deferred code executed correctly' 43 | ); 44 | 45 | ok($example->immediate->is_done, 'immediate method marked as done immediately after call'); 46 | ok(!(my $ret = $example->immediate_deferred)->is_done, '... but with the :Defer attribute, still pending'); 47 | note explain $ret->state; 48 | await Future->needs_any( 49 | $ret, 50 | $loop->timeout_future(after => 1) 51 | ); 52 | ok($ret->is_done, '... resolving correctly after some time has passed'); 53 | 54 | done_testing; 55 | -------------------------------------------------------------------------------- /t/define_role.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | 5 | BEGIN { 6 | binmode STDOUT, ':encoding(UTF-8)'; 7 | binmode STDERR, ':encoding(UTF-8)'; 8 | } 9 | 10 | use Test::More; 11 | use Object::Pad qw(:experimental(mop)); 12 | 13 | subtest 'create a rôle' => sub { 14 | ok(eval <<'EOF', 'create rôle') 15 | package Example::Role; 16 | use Myriad::Class type => 'role'; 17 | 1; 18 | EOF 19 | or diag explain $@; 20 | ok(my $mop = Object::Pad::MOP::Class->for_class('Example::Role'), 'MOP exists'); 21 | ok($mop->is_role, 'and we created a rôle'); 22 | done_testing; 23 | }; 24 | 25 | done_testing; 26 | -------------------------------------------------------------------------------- /t/exception.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package Local::Test; 5 | use Test::More; 6 | use Test::Fatal; 7 | 8 | use Myriad::Exception::Builder; 9 | 10 | is(exception { 11 | declare_exception Example => category => 'some_category', message => 'this is a message'; 12 | }, undef, 'can declare an exception with category and message'); 13 | 14 | subtest 'can declare exceptions' => sub { 15 | can_ok('Myriad::Exception::Local::Test::Example', qw(new category message reason throw)); 16 | my $ex = new_ok('Myriad::Exception::Local::Test::Example' => [ 17 | ]); 18 | is($ex->message, 'this is a message (category=some_category)', 'message is correct'); 19 | is($ex->category, 'some_category', 'category is correct'); 20 | is("$ex", 'this is a message (category=some_category)', 'stringifies too'); 21 | }; 22 | 23 | done_testing; 24 | 25 | __END__ 26 | 27 | subtest 'needs category' => sub { 28 | like(exception { 29 | package Exception::Example::MissingCategory; 30 | Myriad::Exception::Builder->import(qw(:immediate)); 31 | }, qr/missing category/, 'refuses to compile an exception class without a category'); 32 | }; 33 | 34 | subtest 'stringifies okay' => sub { 35 | is(exception { 36 | package Exception::Example::Stringification; 37 | sub category { 'example' } 38 | sub message { 'example message' } 39 | Myriad::Exception::Builder->import(qw(:immediate)); 40 | }, undef, 'simple exception class can be defined'); 41 | my $ex = new_ok('Exception::Example::Stringification'); 42 | can_ok($ex, qw(new throw message category)); 43 | is("$ex", 'example message', 'stringifies okay'); 44 | }; 45 | 46 | subtest 'can ->throw' => sub { 47 | is(exception { 48 | package Exception::Example::Throwable; 49 | sub category { 'example' } 50 | sub message { 'this was thrown' } 51 | Myriad::Exception::Builder->import(qw(:immediate)); 52 | }, undef, 'simple exception class can be defined'); 53 | isa_ok(my $ex = exception { 54 | Exception::Example::Throwable->throw; 55 | }, qw(Exception::Example::Throwable)); 56 | is("$ex", 'this was thrown', 'message survived'); 57 | }; 58 | 59 | done_testing; 60 | 61 | -------------------------------------------------------------------------------- /t/myriad.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Myriad; 5 | use Myriad::Commands; 6 | use Test::More; 7 | use Test::Fatal; 8 | use Test::MockModule; 9 | use Test::MockObject; 10 | use Future::AsyncAwait; 11 | use IO::Async::Test; 12 | 13 | use Object::Pad qw(:experimental(mop)); 14 | 15 | sub loop_notifiers { 16 | my $loop = shift; 17 | 18 | my @current_notifiers = $loop->notifiers; 19 | my %loaded_in_loop = map { ref() => 1 } @current_notifiers; 20 | return \%loaded_in_loop; 21 | } 22 | 23 | my $command_module = Test::MockModule->new('Myriad::Commands'); 24 | my $command = 'test'; 25 | my $command_is_called = 0; 26 | $command_module->mock($command, async sub { my ($self, $param) = @_; $command_is_called = $param; }); 27 | 28 | my $myriad = new_ok('Myriad'); 29 | my $metaclass = Object::Pad::MOP::Class->for_class('Myriad'); 30 | my $loop = $myriad->loop; 31 | testing_loop($loop); 32 | 33 | subtest "class methods and proper initialization" => sub { 34 | can_ok($myriad, qw(configure_from_argv loop registry redis_transport memory_transport transport rpc_client rpc http subscription storage add_service service_by_name ryu shutdown run)); 35 | 36 | 37 | my $command_param = 'Testing'; 38 | wait_for_future($myriad->configure_from_argv('-l', 'debug', '--subscription_transport', 'memory', '--rpc_transport', 'memory', '--storage_transport', 'memory', $command, $command_param))->get; 39 | 40 | # Check configure_from_argv init objects 41 | my $loop = $metaclass->get_field('$loop')->value($myriad); 42 | isa_ok($loop, 'IO::Async::Loop', 'Loop is set'); 43 | isa_ok($myriad->config, 'Myriad::Config', 'Config is set'); 44 | 45 | # Logging setup 46 | is($myriad->config->log_level, 'debug', 'Log level matching'); 47 | isa_ok(@{$myriad->config->log_level->{subscriptions}}[0], 'CODE', 'Logging has been setup'); 48 | 49 | # Tracing setup 50 | isa_ok($metaclass->get_field('$tracing')->value($myriad), 'Net::Async::OpenTracing', 'Tracing is set'); 51 | my $shutdown_tasks = $metaclass->get_field('$shutdown_tasks')->value($myriad); 52 | isa_ok($shutdown_tasks->[-1], 'CODE', 'Added to shutdown tasks'); 53 | is(@$shutdown_tasks, 1, 'One added shutdown task'); 54 | 55 | my $current_notifiers = loop_notifiers($myriad->loop); 56 | ok($current_notifiers->{'Net::Async::OpenTracing'}, 'Tracing is added to loop'); 57 | 58 | # Since we passing test command 59 | # No Service, or plugin is setup. 60 | 61 | # Command 62 | isa_ok($metaclass->get_field('$commands')->value($myriad), 'Myriad::Commands', 'Command is set'); 63 | like($command_is_called, qr/$command_param/, 'Test Command has been found and called'); 64 | 65 | }; 66 | 67 | subtest "Myriad attributes setting tests" => sub { 68 | 69 | # RPC 70 | my $rpc = $myriad->rpc; 71 | isa_ok($metaclass->get_field('$rpc')->value($myriad), 'Myriad::RPC::Implementation::Memory', 'Myriad RPC is set'); 72 | my $current_notifiers = loop_notifiers($myriad->loop); 73 | ok($current_notifiers->{'Myriad::RPC::Implementation::Memory'}, 'RPC is added to loop'); 74 | my $shutdown_tasks = $metaclass->get_field('$shutdown_tasks')->value($myriad); 75 | isa_ok($shutdown_tasks->[-1], 'CODE', 'Added to shutdown tasks'); 76 | is(@$shutdown_tasks, 2, 'Two added shutdown tasks'); 77 | 78 | # RPC Client 79 | my $rpc_client = $myriad->rpc_client; 80 | isa_ok($rpc_client, 'Myriad::RPC::Client::Implementation::Memory', 'Myriad RPC Client is set'); 81 | $current_notifiers = loop_notifiers($myriad->loop); 82 | ok($current_notifiers->{'Myriad::RPC::Client::Implementation::Memory'}, 'RPC Cleint is added to loop'); 83 | 84 | # HTTP 85 | my $http = $myriad->http; 86 | isa_ok($metaclass->get_field('$http')->value($myriad), 'Myriad::Transport::HTTP', 'Myriad HTTP is set'); 87 | $current_notifiers = loop_notifiers($myriad->loop); 88 | ok($current_notifiers->{'Myriad::Transport::HTTP'}, 'HTTP is added to loop'); 89 | 90 | # Subscription 91 | my $subscription = $myriad->subscription; 92 | isa_ok($metaclass->get_field('$subscription')->value($myriad), 'Myriad::Subscription::Implementation::Memory', 'Myriad Subscription is set'); 93 | $current_notifiers = loop_notifiers($myriad->loop); 94 | ok($current_notifiers->{'Myriad::Subscription::Implementation::Memory'}, 'Subscription is added to loop'); 95 | 96 | # Storage 97 | my $storage = $myriad->storage; 98 | isa_ok($metaclass->get_field('$storage')->value($myriad), 'Myriad::Storage::Implementation::Memory', 'Myriad Storage is set'); 99 | 100 | # Registry and ryu 101 | isa_ok($myriad->registry, 'Myriad::Registry', 'Myriad::Registry is set'); 102 | my $ryu = $myriad->ryu; 103 | isa_ok($metaclass->get_field('$ryu')->value($myriad), 'Ryu::Async', 'Myriad Ryu is set'); 104 | $current_notifiers = loop_notifiers($myriad->loop); 105 | ok($current_notifiers->{'Ryu::Async'}, 'Ryu is added to loop'); 106 | 107 | }; 108 | 109 | subtest "Run and shutdown behaviour" => sub { 110 | 111 | like(exception { 112 | wait_for_future($myriad->shutdown)->get 113 | }, qr/attempting to shut down before we have started,/, 'can not shutdown as nothing started yet.'); 114 | 115 | my $shutdown_task_called = 0; 116 | my $shutdown_test = async sub { pass('Shutdown task has been called'); $shutdown_task_called++; return; }; 117 | my $service_mock = Test::MockObject->new(); 118 | $service_mock->mock( 'shutdown', $shutdown_test ); 119 | 120 | $metaclass->get_field('$shutdown_tasks')->value($myriad) = [$shutdown_test]; 121 | $metaclass->get_field('$services')->value($myriad) = { testing_service => $service_mock }; 122 | 123 | wait_for_future(Future->needs_all( 124 | $loop->delay_future(after => 0)->on_ready(sub { 125 | is(exception { 126 | wait_for_future($myriad->shutdown)->get 127 | }, undef, 'can shut down without exceptions arising'); 128 | }), 129 | $myriad->run, 130 | ))->get; 131 | 132 | is($shutdown_task_called, 2, 'both shutdown operations has been called successfully'); 133 | 134 | }; 135 | done_testing; 136 | -------------------------------------------------------------------------------- /t/redis.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | 7 | use Myriad::Transport::Redis; 8 | 9 | isa_ok('Myriad::Transport::Redis', 'IO::Async::Notifier'); 10 | 11 | done_testing; 12 | -------------------------------------------------------------------------------- /t/registry.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Deep; 6 | use Test::Fatal; 7 | use Log::Any::Adapter qw(TAP); 8 | use Test::MockModule; 9 | use IO::Async::Loop; 10 | use IO::Async::Test; 11 | use Future::AsyncAwait; 12 | # Needed to set Testing::Service method names without fully defining service as Myriad::Service 13 | use Sub::Util qw(subname set_subname); 14 | use Object::Pad qw(:experimental(mop)); 15 | 16 | use Myriad; 17 | use Myriad::Registry; 18 | use Myriad::Config; 19 | 20 | my $started_services; 21 | BEGIN { 22 | my $service_module = Test::MockModule->new('Myriad::Service::Implementation'); 23 | $service_module->mock(start => async sub { my ($self) = @_; $started_services->{ref($self)} = 1; }); 24 | } 25 | 26 | my $loop = IO::Async::Loop->new; 27 | testing_loop($loop); 28 | 29 | sub loop_notifiers { 30 | my $loop = shift; 31 | 32 | my @current_notifiers = $loop->notifiers; 33 | my %loaded_in_loop = map { ref($_) => 1 } @current_notifiers; 34 | return \%loaded_in_loop; 35 | } 36 | 37 | my $METHODS_MAP = { 38 | rpc => 'rpc_for', 39 | batch => 'batches_for', 40 | emitter => 'emitters_for', 41 | receiver => 'receivers_for' 42 | }; 43 | sub component_for_method { 44 | my $method = shift; 45 | 46 | return $METHODS_MAP->{$method}; 47 | } 48 | 49 | my $myriad_meta = Object::Pad::MOP::Class->for_class('Myriad'); 50 | my $reg_meta = Object::Pad::MOP::Class->for_class('Myriad::Registry'); 51 | 52 | subtest "Adding and viewing components" => sub { 53 | 54 | my $registry = new_ok('Myriad::Registry'); 55 | is $loop->add($registry), undef, "Registry Notifier class added to Loop just fine."; 56 | 57 | my $srv_class = 'Testing::Service'; 58 | # RPC & Batch & emitter & receiver component 59 | for my $component (qw(rpc batch emitter receiver)){ 60 | my $sub_name = "dummy_$component"; 61 | my $dummy_sub = set_subname join('::', $srv_class, $sub_name),sub {}; 62 | my $args = {}; 63 | $args->{channel} = $sub_name if $component eq 'emitter' || $component eq 'receiver'; 64 | $args->{service} = $registry->make_service_name($srv_class) if $component eq 'receiver'; 65 | my $slot = {"$srv_class" => { $sub_name => {args => $args, code => $dummy_sub}}}; 66 | 67 | my $add = join '_', 'add', $component; 68 | 69 | my $for = component_for_method($component); 70 | 71 | # Always pass empty $args only with receiver set service name 72 | $registry->$add($srv_class, $sub_name, $dummy_sub, $component eq 'receiver'? {'service' => $srv_class} : {}); 73 | my $reg_slot = $reg_meta->get_field('%'.$component)->value($registry); 74 | cmp_deeply($reg_slot, $slot, "added $component"); 75 | 76 | my $for_method = $registry->$for($srv_class); 77 | cmp_deeply($for_method, $slot->{$srv_class}, "$component for service"); 78 | 79 | # Test calling $component_for unknown classes 80 | $for_method = exception {$registry->$for("Not::Added::Empty::Class")}; 81 | isa_ok($for_method, 'Myriad::Exception::Registry::UnknownClass', "Exception for trying to get empty $component for un_added services"); 82 | } 83 | 84 | }; 85 | 86 | subtest "Adding Service" => sub { 87 | 88 | my $myriad = new_ok('Myriad'); 89 | my $config = new_ok('Myriad::Config' => [commandline => ['--transport', 'memory']]); 90 | $myriad_meta->get_field('$config')->value($myriad) = $config; 91 | my $registry = $Myriad::REGISTRY; 92 | 93 | # Define our testing service 94 | BEGIN { 95 | package Testing::Service; 96 | use Myriad::Service; 97 | 98 | async method inc_test : RPC (%args) { 99 | my $value = $args{value}; 100 | return ++$value; 101 | } 102 | 103 | async method batch_test : Batch (%args) { 104 | return 1; 105 | } 106 | } 107 | # Just by defining it, it will be configured. But not yet added or started. 108 | 109 | # Add service in our registry. 110 | wait_for_future($registry->add_service(myriad => $myriad, service => 'Testing::Service'))->get; 111 | 112 | # Get registered services in Myriad 113 | my $services = $myriad_meta->get_field('$services')->value($myriad); 114 | # We should be having only one. 115 | is (keys %$services, 1, 'Only one service is added'); 116 | my ($service) = values %$services; 117 | # Service name is set 118 | my $service_name = $service->service_name; 119 | like($registry->make_service_name('Testing::Service'), qr/$service_name/, "Service name is set correctly"); 120 | 121 | my $srv_meta = Object::Pad::MOP::Class->for_class(ref $service); 122 | # Calling empty _for for an added service will not trigger exception. reveiver and emitter in this case. 123 | my ($rpc, $batch, $receiver, $emitter) = map { 124 | $registry->${\component_for_method($_)}('Testing::Service') 125 | } qw(rpc batch receiver emitter); 126 | cmp_deeply([ 127 | map { keys %$_ } $rpc, $batch, $receiver, $emitter 128 | ], 129 | bag(qw(inc_test batch_test)), 130 | 'Registry components configured after service adding' 131 | ); 132 | 133 | my $current_notifiers = loop_notifiers($myriad->loop); 134 | ok($current_notifiers->{'Testing::Service'}, 'Testing::Service is added to loop'); 135 | 136 | my $srv_in_registry = $registry->service_by_name($registry->make_service_name('Testing::Service')); 137 | cmp_deeply($service, $srv_in_registry, 'Same service in Myriad and Regisrty'); 138 | is($started_services->{'Testing::Service'}, undef, 'Registry has not started service'); 139 | }; 140 | 141 | subtest "Service name" => sub { 142 | 143 | my $registry = new_ok('Myriad::Registry'); 144 | my $reg_srv_name = $registry->make_service_name('Test::Name'); 145 | # Only lower case sepatated by .(dot) 146 | like ($reg_srv_name, qr/^[a-z']+\.[a-z']+$/, 'passing regex service name'); 147 | 148 | my $ex = exception { 149 | $registry->service_by_name("Not::Found::Service") 150 | }; 151 | isa_ok($ex, 'Myriad::Exception::Registry::ServiceNotFound', "Exception for trying to get undef service") or note explain $ex; 152 | 153 | # Should remove the namespace from the service name; 154 | $reg_srv_name = $registry->make_service_name('Test::Module::Service', 'Test::Module::'); 155 | like ($reg_srv_name, qr/^service$/, 'namespace applied correctly'); 156 | }; 157 | 158 | done_testing; 159 | -------------------------------------------------------------------------------- /t/role.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use utf8; 5 | 6 | BEGIN { 7 | # at the time of writing the Test2 'UTF8' plugin still uses :utf8 if left to its own devices 8 | binmode STDOUT, ':encoding(UTF-8)'; 9 | binmode STDERR, ':encoding(UTF-8)'; 10 | } 11 | 12 | use Test::More; 13 | use Test::Fatal; 14 | use Test::Deep; 15 | use Object::Pad qw(:experimental(mop)); 16 | 17 | is(exception { 18 | eval <<'EOS' or die $@; 19 | package Example::Role { 20 | use Myriad::Role; 21 | method example; 22 | } 23 | 24 | package Example::Class { 25 | use Myriad::Class does => 'Example::Role'; 26 | field $something; 27 | method example { $self } 28 | } 29 | 1 30 | EOS 31 | }, undef, 'can create a class') or die explain $@; 32 | my $obj = new_ok('Example::Class'); 33 | is($obj->example, $obj, 'can call a method'); 34 | cmp_deeply([ map { $_->name } Object::Pad::MOP::Class->for_class('Example::Class')->roles ], bag('Example::Role'), 'have expected rôle'); 35 | done_testing; 36 | 37 | -------------------------------------------------------------------------------- /t/service-bus.t: -------------------------------------------------------------------------------- 1 | use Myriad::Class; 2 | 3 | use Test::More; 4 | use Test::Deep qw(bag cmp_deeply); 5 | use Test::Fatal; 6 | use Test::Myriad; 7 | use Log::Any::Adapter qw(TAP); 8 | 9 | use Future; 10 | use Future::AsyncAwait; 11 | use Object::Pad; 12 | 13 | package Test::Sender { 14 | use Myriad::Service; 15 | 16 | field $bus; 17 | 18 | async method startup { 19 | $log->debugf('Startup first'); 20 | $bus = $api->service_by_name('test.receiver')->bus; 21 | $log->debugf('Startup complete'); 22 | } 23 | 24 | async method send:RPC (%args) { 25 | $log->debugf('Calling send with %s', \%args); 26 | try { 27 | $log->debugf('Send to remote bus'); 28 | $bus->events->emit($args{data}); 29 | return; 30 | } catch ($e) { 31 | $log->errorf('Failed to send - %s', $e); 32 | } 33 | } 34 | } 35 | 36 | package Test::Receiver { 37 | use Myriad::Service; 38 | 39 | field $events = [ ]; 40 | 41 | async method startup { 42 | $api->bus->events->each(sub ($ev) { 43 | $log->debugf('Have event: %s', $ev); 44 | push $events->@*, $ev; 45 | }); 46 | } 47 | async method events:RPC { 48 | return $events; 49 | } 50 | } 51 | my $sender; 52 | my $receiver; 53 | 54 | BEGIN { 55 | $receiver = Test::Myriad->add_service(service => 'Test::Receiver'); 56 | $sender = Test::Myriad->add_service(service => 'Test::Sender'); 57 | } 58 | 59 | try { 60 | await Test::Myriad->ready(); 61 | note 'call RPC'; 62 | await $sender->call_rpc('send', data => 'test data'); 63 | note 'check results'; 64 | my $srv = $Myriad::REGISTRY->service_by_name('test.receiver'); 65 | my $ev = await $srv->events; 66 | note explain $ev; 67 | cmp_deeply($ev, bag('test data'), 'have events after sending'); 68 | } catch ($e) { 69 | note explain $e; 70 | die $e; 71 | } 72 | done_testing; 73 | 74 | -------------------------------------------------------------------------------- /t/service-lifecycle.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal qw(lives_ok exception); 6 | 7 | use IO::Async::Loop; 8 | use IO::Async::Test; 9 | 10 | use Log::Any::Test; 11 | use Log::Any qw($log); 12 | use Log::Any::Adapter qw(TAP); 13 | 14 | use Myriad; 15 | 16 | my $loop = IO::Async::Loop->new(); 17 | testing_loop($loop); 18 | 19 | sub get_myriad { 20 | $ENV{MYRIAD_TRANSPORT} = 'memory'; 21 | return Myriad->new(); 22 | } 23 | 24 | subtest 'It should throw if it failed to find required config' => sub { 25 | 26 | package Should::Fail { 27 | use Myriad::Service; 28 | 29 | config 'required_config'; 30 | 31 | async method startup { 32 | die 'startup should not be reachable'; 33 | } 34 | }; 35 | 36 | my $myriad = get_myriad; 37 | $myriad->configure_from_argv(service => 'Should::Fail')->get(); 38 | like( exception { $myriad->run->get }, 39 | qr/A required configuration key was not set/, 40 | 'exception has been thrown' 41 | ); 42 | 43 | }; 44 | 45 | subtest 'API should be available on startup' => sub { 46 | package Dummy::Service { 47 | use Myriad::Service; 48 | use Test::More; 49 | 50 | async method startup { 51 | isa_ok($api, 'Myriad::API', 'API is defined at startup'); 52 | die 'testing done'; 53 | } 54 | }; 55 | 56 | my $myriad = get_myriad; 57 | $myriad->configure_from_argv(service => 'Dummy::Service')->get; 58 | lives_ok { $myriad->run->get }; 59 | }; 60 | 61 | subtest 'diagnostics should be called after startup' => sub { 62 | package Diag::Test { 63 | use Myriad::Service; 64 | use Test::More; 65 | 66 | field $called = 0; 67 | 68 | async method startup { 69 | $called++; 70 | } 71 | 72 | async method diagnostics ($level) { 73 | is($called, 1, 'diagnostics has been called after startup'); 74 | die 'testing done'; 75 | } 76 | }; 77 | 78 | my $myriad = get_myriad; 79 | $myriad->configure_from_argv(service => 'Diag::Test')->get; 80 | lives_ok { $myriad->run->get }; 81 | }; 82 | 83 | done_testing; 84 | -------------------------------------------------------------------------------- /t/storage.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | BEGIN { 5 | # Enforce deferred operation for in-process Perl module 6 | $ENV{MYRIAD_RANDOM_DELAY} = 0.001; 7 | } 8 | use Future; 9 | use Future::AsyncAwait; 10 | use Test::More; 11 | use Test::MemoryGrowth; 12 | use Log::Any qw($log); 13 | use Log::Any::Adapter qw(TAP); 14 | 15 | use Myriad::Mutex; 16 | use Myriad::Storage::Implementation::Memory; 17 | 18 | use IO::Async::Test; 19 | use IO::Async::Loop; 20 | 21 | my $loop = IO::Async::Loop->new; 22 | my $redis; 23 | testing_loop( $loop ); 24 | 25 | my @classes = (['Myriad::Storage::Implementation::Memory', []]); 26 | 27 | if ($ENV{MYRIAD_TRANSPORT} and $ENV{MYRIAD_TRANSPORT} ne 'memory') { 28 | require Myriad::Transport::Redis; 29 | require Myriad::Storage::Implementation::Redis; 30 | $loop->add( 31 | $redis = Myriad::Transport::Redis->new(redis_uri => $ENV{MYRIAD_TRANSPORT}, cluster => $ENV{MYRIAD_TRANSPORT_CLUSTER}) 32 | ); 33 | $redis->start()->get(); 34 | push @classes, ['Myriad::Storage::Implementation::Redis', [redis => $redis]]; 35 | } 36 | 37 | for my $class (@classes) { 38 | subtest $class->[0] => sub { 39 | my $storage = new_ok($class->[0], $class->[1]); 40 | # Implementation::Memory is a IO::Async::Notifier 41 | # while Implementation::Redis is not 42 | # worth checking an unifyig that. but for now 43 | $loop->add($storage) if $class->[0] eq 'Myriad::Storage::Implementation::Memory'; 44 | 45 | # Hash 46 | (async sub { 47 | await $storage->set(some_key => 'value'); 48 | is(await $storage->get('some_key'), 'value', 'can read our value back'); 49 | await $storage->hash_set(some_hash => key => 'hash value'); 50 | is(await $storage->hash_get('some_hash', 'key'), 'hash value', 'can read our hash value back'); 51 | is(await $storage->hash_add('some_hash', 'numeric', 3), 3, 'can increment a hash value'); 52 | is(await $storage->hash_add('some_hash', 'numeric', 2), 5, 'can increment a hash value again'); 53 | is(await $storage->hash_get('some_hash', 'key'), 'hash value', 'can read our original hash value back'); 54 | })->()->get; 55 | 56 | # OrderedSet 57 | (async sub { 58 | await $storage->orderedset_add('sortedset_key', 1, 'one'); 59 | await $storage->orderedset_add('sortedset_key', 2, 'two'); 60 | await $storage->orderedset_add('sortedset_key', 3, 'three'); 61 | await $storage->orderedset_add('sortedset_key', 4, 'four'); 62 | is(await $storage->orderedset_member_count('sortedset_key', 2 => 4), 3, 'correct initial bounded scored orderedset count'); 63 | is(await $storage->orderedset_remove_member('sortedset_key', 'three'), 1, 'able to remove a member from an orderedset'); 64 | is_deeply(await $storage->orderedset_members('sortedset_key', '-inf', 4, 1), ['one', 1, 'two', 2, 'four', 4], 'able to retrieve members'); 65 | is(await $storage->orderedset_remove_byscore('sortedset_key', 0, 2), 2, 'able to remove byscore for a sortedset'); 66 | is(await $storage->orderedset_member_count('sortedset_key', '-inf', '+inf'), 1, 'correct unbounded scored orderedset count'); 67 | is_deeply(await $storage->orderedset_members('sortedset_key', '-inf', '+inf'), ['four'], 'able to retrieve members without scores'); 68 | })->()->get; 69 | 70 | (async sub { 71 | my $f = $storage->when_key_changed('mutex_key'); 72 | isa_ok($f, 'Future'); 73 | is($f->state, 'pending', 'start with a valid pending Future'); 74 | await $storage->get(mutex_key => ); 75 | is($f->state, 'pending', 'still pending after a get'); 76 | await $storage->set(mutex_key => 123); 77 | is($f->state, 'done', 'no longer pending after set'); 78 | await $storage->set(missing_key => 123); 79 | await $storage->set_unless_exists(missing_key => 456); 80 | is(await $storage->get(missing_key => ), 123, '->set_unless_exists does not override existing key'); 81 | })->()->get; 82 | 83 | (async sub { 84 | my $mutex = new_ok('Myriad::Mutex', [ 85 | id => 123, 86 | key => 'testing_key', 87 | storage => $storage, 88 | ttl => 5, 89 | loop => $loop, 90 | ]); 91 | my $f = $mutex->acquire; 92 | isa_ok($f, 'Future'); 93 | ok(!$f->is_ready, 'acquire starts off incomplete'); 94 | await $f; 95 | ok($f->is_done, 'succeeds'); 96 | await $mutex->release; 97 | })->()->get; 98 | 99 | done_testing; 100 | }; 101 | } 102 | 103 | done_testing; 104 | 105 | -------------------------------------------------------------------------------- /t/transport/memory.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Test::Fatal; 6 | use Scalar::Util qw(looks_like_number); 7 | 8 | use Object::Pad; 9 | use Myriad::Transport::Memory; 10 | 11 | use IO::Async::Loop; 12 | my $loop = IO::Async::Loop->new(); 13 | 14 | $loop->add(my $transport = Myriad::Transport::Memory->new()); 15 | 16 | subtest 'In-Memory streams tests' => sub { 17 | my $id = $transport->add_to_stream('stream_1', key => 'value')->get(); 18 | ok(looks_like_number($id), 'it should return new message id'); 19 | 20 | $id = $transport->add_to_stream('stream_1', key => 'value')->get(); 21 | is($id, 1, 'it should return a new ID for new message in the same stream'); 22 | }; 23 | 24 | 25 | subtest 'In-Memory streams read' => sub { 26 | $transport->add_to_stream('stream_read', key => $_)->get() for (0..9); 27 | my $messages = $transport->read_from_stream('stream_read')->get(); 28 | is(0 + keys(%$messages), 50, 'messages has been received correctly'); 29 | 30 | $messages = $transport->read_from_stream('stream_read', 5, 1)->get(); 31 | is(keys %$messages, 1, 'it should respect messages read limit'); 32 | is($messages->{5}->{key}, 5, 'it should respect messages read offset'); 33 | 34 | $messages = $transport->read_from_stream('does not exist')->get(); 35 | is(keys %$messages, 0, 'it should return an empty array of stream not found'); 36 | }; 37 | 38 | subtest 'In-Memory strams consumer groups' => sub { 39 | like(exception { 40 | $transport->create_consumer_group('stream does not exist', 'group_name')->get(); 41 | }, qr{^The given stream does not exist.*}, 'it should throw an exception if stream does not exist'); 42 | 43 | $transport->create_consumer_group('consumer_stream', 'test_group', 0, 1)->get(); 44 | 45 | $transport->add_to_stream('consumer_stream', key => $_)->get() for (0..99); 46 | 47 | my $first_consumer_message = $transport->read_from_stream_by_consumer('consumer_stream', 'test_group', 'consumer_1', 0, 1)->get(); 48 | my $second_consumer_message = $transport->read_from_stream_by_consumer('consumer_stream', 'test_group', 'consumer_2', 0, 1)->get(); 49 | ok($first_consumer_message->{0} && $second_consumer_message->{1}, 'it should deliver two different messages'); 50 | 51 | # you can't claim a message after acknowledging it 52 | $transport->ack_message('consumer_stream', 'test_group', 0)->get(); 53 | my $message = $transport->claim_message('consumer_stream', 'test_group', 'new_consumer', 0)->get(); 54 | 55 | ok(keys %$message == 0, 'it should not allow claiming acknowledged messages'); 56 | 57 | $message = $transport->claim_message('consumer_stream', 'test_group', 'new_consumer', 1)->get(); 58 | ok($message, 'it should allow re-claiming messages'); 59 | 60 | }; 61 | 62 | 63 | subtest 'In-Memory pub/sub' => sub { 64 | my $sub = $transport->subscribe('sub')->get(); 65 | isa_ok($sub, 'Ryu::Source', 'it should return a Ryu::Source'); 66 | 67 | $sub->take(1)->each(sub { 68 | is(shift, 'message', 'it should publish the messages'); 69 | }); 70 | 71 | $transport->publish('sub', 'message')->get(); 72 | }; 73 | 74 | done_testing(); 75 | -------------------------------------------------------------------------------- /t/util/secret.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | use Data::Dumper; 6 | 7 | use Myriad::Util::Secret; 8 | 9 | subtest 'basic secret handling' => sub { 10 | my $secret = new_ok('Myriad::Util::Secret' => [ "example" ]); 11 | is("$secret", '***', 'string returns placeholder value'); 12 | cmp_ok($secret, 'ne', '***', 'but string is not equal to placeholder value'); 13 | cmp_ok($secret, 'eq', 'example', 'and string is equal to original value'); 14 | is($secret->secret_value, 'example', 'and real value is accessible via dedicated method'); 15 | unlike(Data::Dumper::Dumper($secret), qr/example/, 'and Data::Dumper doesn\'t give away any secrets'); 16 | done_testing; 17 | }; 18 | 19 | subtest 'edge cases for secrets and comparisons' => sub { 20 | for my $case ( 21 | '', 22 | 0, 23 | 1, 24 | '0e0', 25 | 'short', 26 | 'a bit longer', 27 | 'quite a lot longer but not really excessive for a secret value', 28 | ('x' x 1024), 29 | ) { 30 | # note $case; 31 | my $secret = new_ok('Myriad::Util::Secret' => [ $case ]); 32 | is($secret, $case, 'secret matches original value'); 33 | is($secret->secret_value, $case, 'and ->secret_value returns expected content'); 34 | ok($secret->equal($case), 'and ->equal is happy'); 35 | is($secret, Myriad::Util::Secret->new($case), 'can also match against another instance'); 36 | } 37 | done_testing; 38 | }; 39 | 40 | done_testing; 41 | 42 | -------------------------------------------------------------------------------- /xt/memory-leak.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | BEGIN { 5 | # Enforce very small delay on deferred operation for in-process Perl module 6 | $ENV{MYRIAD_RANDOM_DELAY} = 0.00001; 7 | } 8 | use Future; 9 | use Future::AsyncAwait; 10 | use Test::More; 11 | use Test::MemoryGrowth; 12 | use Myriad::Storage::Implementation::Memory; 13 | 14 | use IO::Async::Test; 15 | use IO::Async::Loop; 16 | 17 | my $loop = IO::Async::Loop->new; 18 | testing_loop( $loop ); 19 | for my $class (qw(Myriad::Storage::Implementation::Memory)) { 20 | subtest $class => sub { 21 | $loop->add( 22 | my $storage = new_ok($class) 23 | ); 24 | # Cut-down version of the tests for a few 25 | # methods, just make sure that we don't go 26 | # crazy with our memory usage 27 | note 'Memory test, this may take a while'; 28 | no_growth { 29 | Future->wait_all( 30 | $storage->set('some_key', 'some_value'), 31 | $storage->hash_set('some_hash_key', 'key', 'a hash value'), 32 | )->get; 33 | Future->wait_all( 34 | $storage->get('some_key'), 35 | $storage->hash_get('some_hash_key', 'key'), 36 | )->get; 37 | () 38 | } calls => 2_000, 39 | 'ensure basic storage operations do not leak memory'; 40 | done_testing; 41 | }; 42 | } 43 | done_testing; 44 | 45 | --------------------------------------------------------------------------------