├── .editorconfig ├── .gitignore ├── .projectile ├── LICENSE.txt ├── Makefile ├── README.md ├── erl_src └── bus.app.src ├── rebar.config ├── rebar.lock ├── shell.nix ├── spago.lock ├── spago.yaml ├── src ├── .dir-locals.el ├── Pinto.erl ├── Pinto.purs └── Pinto │ ├── App.purs │ ├── GenServer.erl │ ├── GenServer.purs │ ├── GenServer │ ├── ContStop.erl │ └── ContStop.purs │ ├── GenServer2.purs │ ├── GenStatem.erl │ ├── GenStatem.purs │ ├── MessageRouting.erl │ ├── MessageRouting.purs │ ├── ModuleNames.purs │ ├── Monitor.erl │ ├── Monitor.purs │ ├── Supervisor.erl │ ├── Supervisor.purs │ ├── Supervisor │ ├── SimpleOneForOne.erl │ └── SimpleOneForOne.purs │ ├── Timer.erl │ ├── Timer.purs │ ├── Types.erl │ └── Types.purs ├── test.dhall ├── test ├── .dir-locals.el ├── DoorLock.purs ├── GenServer.erl ├── GenServer.purs ├── GenServer │ └── ContStop.purs ├── GenServer2.purs ├── Main.erl ├── Main.purs ├── TestHelpers.erl ├── TestHelpers.purs ├── ValueServer.purs └── rebar3.config └── thoughts.md /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://editorconfig.org 2 | root = true 3 | 4 | [*] 5 | indent_style = space 6 | indent_size = 2 7 | insert_final_newline = true 8 | trim_trailing_whitespace = true 9 | end_of_line = lf 10 | charset = utf-8 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .psc-ide-port 2 | .psc-package/ 3 | .spago/ 4 | output/ 5 | *beam 6 | tags 7 | _build 8 | generated-docs 9 | erl_crash.dump 10 | -------------------------------------------------------------------------------- /.projectile: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/id3as/purescript-erl-pinto/7cfd871aa9ce6ea1788a07e66f188a433a7bd8db/.projectile -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Apache License 2 | Version 2.0, January 2004 3 | http://www.apache.org/licenses/ 4 | 5 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 6 | 7 | 1. Definitions. 8 | 9 | "License" shall mean the terms and conditions for use, reproduction, 10 | and distribution as defined by Sections 1 through 9 of this document. 11 | 12 | "Licensor" shall mean the copyright owner or entity authorized by 13 | the copyright owner that is granting the License. 14 | 15 | "Legal Entity" shall mean the union of the acting entity and all 16 | other entities that control, are controlled by, or are under common 17 | control with that entity. For the purposes of this definition, 18 | "control" means (i) the power, direct or indirect, to cause the 19 | direction or management of such entity, whether by contract or 20 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 21 | outstanding shares, or (iii) beneficial ownership of such entity. 22 | 23 | "You" (or "Your") shall mean an individual or Legal Entity 24 | exercising permissions granted by this License. 25 | 26 | "Source" form shall mean the preferred form for making modifications, 27 | including but not limited to software source code, documentation 28 | source, and configuration files. 29 | 30 | "Object" form shall mean any form resulting from mechanical 31 | transformation or translation of a Source form, including but 32 | not limited to compiled object code, generated documentation, 33 | and conversions to other media types. 34 | 35 | "Work" shall mean the work of authorship, whether in Source or 36 | Object form, made available under the License, as indicated by a 37 | copyright notice that is included in or attached to the work 38 | (an example is provided in the Appendix below). 39 | 40 | "Derivative Works" shall mean any work, whether in Source or Object 41 | form, that is based on (or derived from) the Work and for which the 42 | editorial revisions, annotations, elaborations, or other modifications 43 | represent, as a whole, an original work of authorship. For the purposes 44 | of this License, Derivative Works shall not include works that remain 45 | separable from, or merely link (or bind by name) to the interfaces of, 46 | the Work and Derivative Works thereof. 47 | 48 | "Contribution" shall mean any work of authorship, including 49 | the original version of the Work and any modifications or additions 50 | to that Work or Derivative Works thereof, that is intentionally 51 | submitted to Licensor for inclusion in the Work by the copyright owner 52 | or by an individual or Legal Entity authorized to submit on behalf of 53 | the copyright owner. For the purposes of this definition, "submitted" 54 | means any form of electronic, verbal, or written communication sent 55 | to the Licensor or its representatives, including but not limited to 56 | communication on electronic mailing lists, source code control systems, 57 | and issue tracking systems that are managed by, or on behalf of, the 58 | Licensor for the purpose of discussing and improving the Work, but 59 | excluding communication that is conspicuously marked or otherwise 60 | designated in writing by the copyright owner as "Not a Contribution." 61 | 62 | "Contributor" shall mean Licensor and any individual or Legal Entity 63 | on behalf of whom a Contribution has been received by Licensor and 64 | subsequently incorporated within the Work. 65 | 66 | 2. Grant of Copyright License. Subject to the terms and conditions of 67 | this License, each Contributor hereby grants to You a perpetual, 68 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 69 | copyright license to reproduce, prepare Derivative Works of, 70 | publicly display, publicly perform, sublicense, and distribute the 71 | Work and such Derivative Works in Source or Object form. 72 | 73 | 3. Grant of Patent License. Subject to the terms and conditions of 74 | this License, each Contributor hereby grants to You a perpetual, 75 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 76 | (except as stated in this section) patent license to make, have made, 77 | use, offer to sell, sell, import, and otherwise transfer the Work, 78 | where such license applies only to those patent claims licensable 79 | by such Contributor that are necessarily infringed by their 80 | Contribution(s) alone or by combination of their Contribution(s) 81 | with the Work to which such Contribution(s) was submitted. If You 82 | institute patent litigation against any entity (including a 83 | cross-claim or counterclaim in a lawsuit) alleging that the Work 84 | or a Contribution incorporated within the Work constitutes direct 85 | or contributory patent infringement, then any patent licenses 86 | granted to You under this License for that Work shall terminate 87 | as of the date such litigation is filed. 88 | 89 | 4. Redistribution. You may reproduce and distribute copies of the 90 | Work or Derivative Works thereof in any medium, with or without 91 | modifications, and in Source or Object form, provided that You 92 | meet the following conditions: 93 | 94 | (a) You must give any other recipients of the Work or 95 | Derivative Works a copy of this License; and 96 | 97 | (b) You must cause any modified files to carry prominent notices 98 | stating that You changed the files; and 99 | 100 | (c) You must retain, in the Source form of any Derivative Works 101 | that You distribute, all copyright, patent, trademark, and 102 | attribution notices from the Source form of the Work, 103 | excluding those notices that do not pertain to any part of 104 | the Derivative Works; and 105 | 106 | (d) If the Work includes a "NOTICE" text file as part of its 107 | distribution, then any Derivative Works that You distribute must 108 | include a readable copy of the attribution notices contained 109 | within such NOTICE file, excluding those notices that do not 110 | pertain to any part of the Derivative Works, in at least one 111 | of the following places: within a NOTICE text file distributed 112 | as part of the Derivative Works; within the Source form or 113 | documentation, if provided along with the Derivative Works; or, 114 | within a display generated by the Derivative Works, if and 115 | wherever such third-party notices normally appear. The contents 116 | of the NOTICE file are for informational purposes only and 117 | do not modify the License. You may add Your own attribution 118 | notices within Derivative Works that You distribute, alongside 119 | or as an addendum to the NOTICE text from the Work, provided 120 | that such additional attribution notices cannot be construed 121 | as modifying the License. 122 | 123 | You may add Your own copyright statement to Your modifications and 124 | may provide additional or different license terms and conditions 125 | for use, reproduction, or distribution of Your modifications, or 126 | for any such Derivative Works as a whole, provided Your use, 127 | reproduction, and distribution of the Work otherwise complies with 128 | the conditions stated in this License. 129 | 130 | 5. Submission of Contributions. Unless You explicitly state otherwise, 131 | any Contribution intentionally submitted for inclusion in the Work 132 | by You to the Licensor shall be under the terms and conditions of 133 | this License, without any additional terms or conditions. 134 | Notwithstanding the above, nothing herein shall supersede or modify 135 | the terms of any separate license agreement you may have executed 136 | with Licensor regarding such Contributions. 137 | 138 | 6. Trademarks. This License does not grant permission to use the trade 139 | names, trademarks, service marks, or product names of the Licensor, 140 | except as required for reasonable and customary use in describing the 141 | origin of the Work and reproducing the content of the NOTICE file. 142 | 143 | 7. Disclaimer of Warranty. Unless required by applicable law or 144 | agreed to in writing, Licensor provides the Work (and each 145 | Contributor provides its Contributions) on an "AS IS" BASIS, 146 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 147 | implied, including, without limitation, any warranties or conditions 148 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 149 | PARTICULAR PURPOSE. You are solely responsible for determining the 150 | appropriateness of using or redistributing the Work and assume any 151 | risks associated with Your exercise of permissions under this License. 152 | 153 | 8. Limitation of Liability. In no event and under no legal theory, 154 | whether in tort (including negligence), contract, or otherwise, 155 | unless required by applicable law (such as deliberate and grossly 156 | negligent acts) or agreed to in writing, shall any Contributor be 157 | liable to You for damages, including any direct, indirect, special, 158 | incidental, or consequential damages of any character arising as a 159 | result of this License or out of the use or inability to use the 160 | Work (including but not limited to damages for loss of goodwill, 161 | work stoppage, computer failure or malfunction, or any and all 162 | other commercial damages or losses), even if such Contributor 163 | has been advised of the possibility of such damages. 164 | 165 | 9. Accepting Warranty or Additional Liability. While redistributing 166 | the Work or Derivative Works thereof, You may choose to offer, 167 | and charge a fee for, acceptance of support, warranty, indemnity, 168 | or other liability obligations and/or rights consistent with this 169 | License. However, in accepting such obligations, You may act only 170 | on Your own behalf and on Your sole responsibility, not on behalf 171 | of any other Contributor, and only if You agree to indemnify, 172 | defend, and hold each Contributor harmless for any liability 173 | incurred by, or claims asserted against, such Contributor by reason 174 | of your accepting any such warranty or additional liability. 175 | 176 | END OF TERMS AND CONDITIONS 177 | 178 | 179 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all test runtest erl ci clean cleandist formatPS 2 | 3 | PS_SRC = src 4 | TEST_SRC = test 5 | 6 | PS_SOURCEFILES = $(shell find ${PS_SRC} -type f -name \*.purs) 7 | PS_ERL_FFI = $(shell find ${PS_SRC} -type f -name \*.erl) 8 | PS_TEST_SOURCEFILES = $(shell find ${TEST_SRC} -type f -name \*.purs) 9 | PS_TEST_ERL_FFI = $(shell find ${TEST_SRC} -type f -name \*.erl) 10 | 11 | 12 | .DEFAULT_GOAL := erl 13 | 14 | all: erl docs 15 | 16 | ci: all test 17 | 18 | output/.complete: .spago $(PS_SOURCEFILES) $(PS_ERL_FFI) 19 | spago build 20 | touch output/.complete 21 | 22 | output/.testcomplete: .spago $(PS_SOURCEFILES) $(PS_ERL_FFI) $(PS_TEST_SOURCEFILES) $(PS_TEST_ERL_FFI) 23 | # Should be able to just use the below, but spago does not pass the testouput directory through to the purs backend 24 | spago -x test.dhall build --purs-args "--censor-codes=ShadowedName,WildcardInferredType" 25 | touch output/.testcomplete 26 | 27 | docs: output/.complete 28 | mkdir -p docs 29 | spago docs --format markdown 30 | cp generated-docs/md/Erl.Quorum*.md docs 31 | 32 | .spago: spago.json test.dhall packages.dhall 33 | spago install 34 | spago -x test.dhall install 35 | touch .spago 36 | 37 | erl: output/.complete 38 | rebar3 as dist compile 39 | 40 | test: rebar.lock output/.testcomplete 41 | rebar3 as test_profile compile 42 | erl -pa ebin -pa $$(rebar3 as test_profile path) -noshell -sname "runner" -eval '(test_main@ps:main())()' -eval 'init:stop()' 43 | 44 | formatPS: 45 | purs-tidy format-in-place src/ test/ 46 | 47 | clean: 48 | rebar3 as dist clean 49 | rebar3 as test_profile clean 50 | rm -rf output 51 | 52 | distclean: clean 53 | rm -rf .spago _build 54 | 55 | runtest: 56 | erl -pa ebin -pa $$(rebar3 as test_profile path) -noshell -sname "runner" -eval '(test_main@ps:main())()' -eval 'init:stop()' 57 | 58 | # Rebar3 won't generate this under profiles 59 | # and without it, our paths are wrong 60 | rebar.lock: rebar.config 61 | rebar3 get-deps 62 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-erl-pinto 2 | 3 | Opinionated Bindings to OTP 4 | 5 | ## Type-safe bindings 6 | 7 | Low level bindings to OTP aren't directly user friendly, so this library goes a step up and while a lot of the functionality is recognisable intuitively from the original OTP documentation, the usage is more function-centric so it reads more like an actual Purescript application. 8 | 9 | ## Define a gen server 10 | ```purescript 11 | 12 | module MyGenServer where 13 | import Pinto (RegistryName(..), StartLinkResult) 14 | import Pinto.GenServer (InitResult(..), ServerPid, ServerType) 15 | import Pinto.GenServer as GenServer 16 | 17 | type EmptyGenServerStartArgs 18 | = {} 19 | 20 | type State 21 | = {} 22 | 23 | serverName :: RegistryName (ServerType Unit Unit Unit State) 24 | serverName = Local $ atom "my_gen_server" 25 | 26 | startLink :: EmptyGenServerStartArgs -> Effect (StartLinkResult (ServerPid Unit Unit Unit State)) 27 | startLink args = GenServer.startLink $ (GenServer.defaultSpec $ init args) { name = Just serverName } 28 | 29 | doSomething :: Effect String 30 | doSomething = GenServer.call (ByName serverName) (\_from state -> pure $ GenServer.reply "Hi" state) 31 | 32 | init :: EmptyGenServerStartArgs -> GenServer.InitFn Unit Unit Unit State 33 | init _args = do 34 | pure $ InitOk {} 35 | 36 | 37 | ``` 38 | 39 | ## Define a gen supervisor that uses that gen server 40 | 41 | ```purescript 42 | 43 | module MySup where 44 | 45 | import Pinto (RegistryName(..), StartLinkResult) 46 | import Pinto.Supervisor 47 | 48 | startLink :: Effect (StartLinkResult SupervisorPid) 49 | startLink = do 50 | Sup.startLink (Just $ Local $ atom "my_sup") init 51 | 52 | init :: Effect SupervisorSpec 53 | init = do 54 | pure 55 | { flags: 56 | { strategy: OneForOne 57 | , intensity: 1 58 | , period: Seconds 5.0 59 | } 60 | , childSpecs: 61 | (spec { id: "cool_worker", 62 | start: MyGenServer.startLink {}, 63 | childType: Worker, 64 | restartStrategy: RestartTransient, 65 | shutdownStrategy: ShutdownTimeout $ Milliseconds 5000.0 66 | }) 67 | : nil 68 | } 69 | 70 | 71 | ``` 72 | 73 | ## Define an application that uses this supervisor 74 | 75 | ```purescript 76 | module MyApp where 77 | 78 | import Pinto.App as App 79 | 80 | start = App.simpleStart MySup.startLink 81 | ``` 82 | 83 | ## Link to it in an ordinary erlang app.src 84 | 85 | ```erlang 86 | {application, my_amazing_app, 87 | [{description, "An OTP application"}, 88 | {vsn, "0.1.0"}, 89 | {registered, []}, 90 | {mod, { myApp@ps, []}}, 91 | {applications, 92 | [kernel, 93 | stdlib 94 | ]} 95 | ]}. 96 | ``` 97 | 98 | An end-to-end example can be found in the [demo project](https://github.com/id3as/demo-ps) 99 | 100 | 101 | Disclaimer 102 | == 103 | 104 | This software, and the opinionated libraries written to support it are very much "works in progress" - we are actively using and building these libraries out for use in own commercial software and can and will be making any changes required to further support that development. As such, they come without support and a disclaimer very much of "be it on your own heads". That said - feel free to reach out and talk to us if you have ideas though, improvements and suggestions are welcome in pull requests and conversation. 105 | 106 | -------------------------------------------------------------------------------- /erl_src/bus.app.src: -------------------------------------------------------------------------------- 1 | {application, bus, 2 | [ {description, "Purerl wrapper on groc message busses"} 3 | , {vsn, "0.0.1"} 4 | , {registered, []} 5 | , {modules, []} 6 | , {applications, [ kernel 7 | , gproc 8 | , stdlib 9 | ]} 10 | , {env, []} 11 | ]}. 12 | -------------------------------------------------------------------------------- /rebar.config: -------------------------------------------------------------------------------- 1 | {deps, [ {gproc, {git, "https://github.com/uwiger/gproc.git", {tag, "0.9.0"}}} 2 | ]}. 3 | 4 | %% 5 | 6 | {profiles, [ 7 | {dist, [{src_dirs, ["erl_src", "output"]}]}, 8 | {test_profile, [ 9 | {deps, []}, 10 | {erl_opts, [debug_info]}, 11 | {src_dirs, ["erl_src", "output"]} 12 | ]} 13 | ]}. 14 | 15 | {src_dirs, ["erl_src"]}. 16 | -------------------------------------------------------------------------------- /rebar.lock: -------------------------------------------------------------------------------- 1 | [{<<"gproc">>, 2 | {git,"https://github.com/uwiger/gproc.git", 3 | {ref,"3737f2b958a5908d7a3870046ae162c5b9bf971c"}}, 4 | 0}]. 5 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | 2 | let 3 | pinnedNixHash = "7c3d4d3af8e9319ccd2a74c31cf247b0fcd08bc2"; 4 | pinnedNix = 5 | builtins.fetchGit { 6 | name = "nixpkgs-pinned"; 7 | url = "https://github.com/NixOS/nixpkgs.git"; 8 | rev = "${pinnedNixHash}"; 9 | }; 10 | 11 | erlangReleases = 12 | builtins.fetchGit { 13 | name = "nixpkgs-nixerl"; 14 | url = "https://github.com/id3as/nixpkgs-nixerl.git"; 15 | rev = "9c74cc241f7a13e2ea8ebe765cb3959501c5c404"; 16 | }; 17 | 18 | purerlReleases = 19 | builtins.fetchGit { 20 | url = "https://github.com/purerl/nixpkgs-purerl.git"; 21 | ref = "master"; 22 | rev = "1d59def257ad38fcbc17782591e5a21df3fd2557"; 23 | }; 24 | 25 | nixpkgs = 26 | import pinnedNix { 27 | overlays = [ 28 | (import erlangReleases) 29 | (import purerlReleases) 30 | ]; 31 | }; 32 | 33 | easy-ps = import 34 | (nixpkgs.pkgs.fetchFromGitHub { 35 | ## Temporarily on Fabrizio's fork to get spago-next 36 | owner = "f-f"; 37 | repo = "easy-purescript-nix"; 38 | rev = "880d958dd9909872629e3f040da2b4ec2ef6e990"; 39 | sha256 = "sha256-+6lTkonRAY6KvDIweRU5DeuWMryFELJTEzg8P2OSjgM="; 40 | }) { pkgs = nixpkgs; }; 41 | 42 | erlang = nixpkgs.nixerl.erlang-25-0; 43 | in 44 | 45 | with nixpkgs; 46 | 47 | mkShell { 48 | buildInputs = with pkgs; [ 49 | 50 | erlang.erlang 51 | erlang.rebar3 52 | erlang.erlang-ls 53 | 54 | # Purescript itself 55 | easy-ps.purs-0_15_7 56 | easy-ps.spago 57 | easy-ps.psa 58 | easy-ps.purescript-language-server 59 | easy-ps.purs-tidy 60 | purerl.purerl-0-0-19 61 | ]; 62 | } 63 | -------------------------------------------------------------------------------- /spago.yaml: -------------------------------------------------------------------------------- 1 | package: 2 | name: erl-pinto 3 | dependencies: 4 | - convertable-options 5 | - datetime 6 | - debug 7 | - effect 8 | - either 9 | - erl-atom 10 | - erl-kernel 11 | - erl-lists 12 | - erl-maps 13 | - erl-modules 14 | - erl-process 15 | - erl-process-trans 16 | - erl-tuples 17 | - erl-untagged-union 18 | - foreign 19 | - functions 20 | - maybe 21 | - partial 22 | - prelude 23 | - transformers 24 | - tuples 25 | - typelevel-prelude 26 | - unsafe-coerce 27 | - erl-test-eunit 28 | - erl-test-eunit-discovery 29 | workspace: 30 | backend: 31 | cmd: purerl 32 | packageSet: 33 | url: https://raw.githubusercontent.com/purerl/package-sets/erl-0.15.3-20220629/packages.json 34 | hash: sha256-kLmZv2u5dWVUUaQEwK0b3T1Ghce5a/hG0zlizaYfcXs= 35 | extraPackages: 36 | erl-process: 37 | dependencies: 38 | - datetime 39 | - effect 40 | - either 41 | - foreign 42 | - integers 43 | - prelude 44 | git: https://github.com/id3as/purescript-erl-process.git 45 | ref: 5df4b6fbac7eeedcbd0f6c731949b1fed8a35b99 46 | erl-test-eunit: 47 | dependencies: 48 | - assert 49 | - console 50 | - debug 51 | - erl-atom 52 | - erl-lists 53 | - erl-tuples 54 | - foreign 55 | - free 56 | - prelude 57 | - psci-support 58 | git: https://github.com/id3as/purescript-erl-test-eunit.git 59 | ref: 2e61fdae477f7c560accea3ffc552a1134f7cc61 60 | erl-test-eunit-discovery: 61 | dependencies: 62 | - effect 63 | - erl-lists 64 | - erl-modules 65 | - erl-test-eunit 66 | - filterable 67 | - foldable-traversable 68 | - free 69 | - maybe 70 | - prelude 71 | git: https://github.com/id3as/purescript-erl-test-eunit-discovery.git 72 | ref: b9cb158f9dbd5e617a1da727fafc14d9d4f0f915 73 | erl-process-trans: 74 | dependencies: 75 | - datetime 76 | - effect 77 | - either 78 | - erl-kernel 79 | - erl-maps 80 | - erl-process 81 | - erl-tuples 82 | - foreign 83 | - maybe 84 | - partial 85 | - prelude 86 | - transformers 87 | - tuples 88 | - typelevel-prelude 89 | - unsafe-coerce 90 | git: https://github.com/id3as/purescript-erl-process-trans.git 91 | ref: 2b48f7ce2d6862245b8e615df0ad25cc41b4bbd2 92 | -------------------------------------------------------------------------------- /src/.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((purescript-mode 5 | (psc-ide-codegen "corefn") 6 | )) 7 | -------------------------------------------------------------------------------- /src/Pinto.erl: -------------------------------------------------------------------------------- 1 | -module(pinto@foreign). 2 | 3 | -export([ isRegisteredImpl/1 4 | , alreadyStartedImpl/1 5 | , node/0 6 | ]). 7 | 8 | isRegisteredImpl(ServerName) -> 9 | fun() -> 10 | case ServerName of 11 | {via, Module, Name} -> 12 | Module:whereis_name(Name); 13 | {global, Name} -> 14 | global:whereis_name(Name); 15 | {local, Name} -> 16 | whereis(Name) 17 | end =/= undefined 18 | end. 19 | 20 | alreadyStartedImpl(Left) -> 21 | fun() -> 22 | case Left of 23 | %% deliberately partialfunction - we want to crash otherwise 24 | {already_started, Pid} -> Pid 25 | end 26 | end. 27 | 28 | node() -> 29 | fun() -> 30 | atom_to_binary(erlang:node(), utf8) 31 | end. 32 | 33 | -------------------------------------------------------------------------------- /src/Pinto.purs: -------------------------------------------------------------------------------- 1 | -- | The base Pinto module re-exports most of the library's useful types and thats about it 2 | module Pinto 3 | ( isRegistered 4 | , node 5 | , module PintoTypeExports 6 | ) where 7 | 8 | import Prelude 9 | import Effect (Effect) 10 | import Erl.Atom (atom) 11 | import Erl.Data.Tuple (tuple2, tuple3) 12 | import Erl.ModuleName (NativeModuleName(..)) 13 | import Erl.Process.Raw (Pid) 14 | import Foreign (Foreign, unsafeToForeign) 15 | import Pinto.Types (RegistryName(..)) 16 | import Pinto.Types (NotStartedReason(..), RegistryName(..), RegistryReference(..), StartLinkResult, TerminateReason(..), crashIfNotRunning, crashIfNotStarted, maybeRunning, maybeStarted, startLinkResultFromPs) as PintoTypeExports 17 | 18 | foreign import isRegisteredImpl :: Foreign -> Effect Boolean 19 | 20 | foreign import alreadyStartedImpl :: Foreign -> Effect Pid 21 | 22 | foreign import node :: Effect String 23 | 24 | -- | Checks if a particular process name is registered using 'whereis_name' 25 | -- | 26 | -- | - `serverType` can be anything, but most likely it'll be GenServer.ServerType or GenStatem.ServerType 27 | isRegistered :: forall serverType. RegistryName serverType -> Effect Boolean 28 | isRegistered (Local name) = isRegisteredImpl $ unsafeToForeign $ tuple2 (atom "local") name 29 | 30 | isRegistered (Global name) = isRegisteredImpl $ unsafeToForeign $ tuple2 (atom "global") name 31 | 32 | isRegistered (Via (NativeModuleName m) name) = isRegisteredImpl $ unsafeToForeign $ tuple3 (atom "via") m name 33 | -------------------------------------------------------------------------------- /src/Pinto/App.purs: -------------------------------------------------------------------------------- 1 | -- | Module roughly representing interactions with the 'application' 2 | -- | See also 'application' in the OTP docs 3 | module Pinto.App where 4 | 5 | import Prelude 6 | import Effect (Effect) 7 | import Effect.Uncurried (mkEffectFn2, EffectFn2) 8 | import Erl.Atom (Atom) 9 | import Erl.Data.List (List) 10 | import Foreign (Foreign) 11 | import Pinto (StartLinkResult, startLinkResultFromPs) 12 | 13 | -- | Defines the entry point to an applicaiton that ignores any passed in arguments and simply calls the supervisor callback provided 14 | -- | 15 | -- | For example: 16 | -- | 17 | -- | ```purescript 18 | -- | App.simpleStart MyGenSup.startLink 19 | -- | ``` 20 | simpleStart :: forall args serverType. Effect (StartLinkResult serverType) -> EffectFn2 Atom (List args) Foreign 21 | simpleStart start = mkEffectFn2 (\_ _ -> startLinkResultFromPs <$> start) 22 | -------------------------------------------------------------------------------- /src/Pinto/GenServer.erl: -------------------------------------------------------------------------------- 1 | -module(pinto_genServer@foreign). 2 | 3 | -include_lib("kernel/include/logger.hrl"). 4 | 5 | -export([ selfFFI/0 6 | , startLinkFFI/3 7 | , startFFI/3 8 | , callFFI/2 9 | , callWithTimeoutFFI/3 10 | , castFFI/2 11 | , replyToFFI/2 12 | , stopFFI/1 13 | , whereIs/1 14 | ]). 15 | 16 | 17 | -import('pinto_types@foreign', 18 | [ start_link_result_to_ps/1 19 | ]). 20 | 21 | -define(just(A), {just, A}). 22 | -define(nothing, {nothing}). 23 | 24 | 25 | startLinkFFI(MaybeName, Module, InitEffect) -> 26 | fun() -> 27 | Result = 28 | case MaybeName of 29 | ?nothing -> 30 | gen_server:start_link(Module, [InitEffect], []); 31 | ?just(Name) -> 32 | gen_server:start_link(Name, Module, [InitEffect], []) 33 | end, 34 | 35 | start_link_result_to_ps(Result) 36 | end. 37 | 38 | startFFI(MaybeName, Module, InitEffect) -> 39 | fun() -> 40 | Result = 41 | case MaybeName of 42 | ?nothing -> 43 | gen_server:start(Module, [InitEffect], []); 44 | ?just(Name) -> 45 | gen_server:start(Name, Module, [InitEffect], []) 46 | end, 47 | 48 | start_link_result_to_ps(Result) 49 | end. 50 | 51 | castFFI(ServerRef, CastFn) -> 52 | fun() -> 53 | gen_server:cast(ServerRef, CastFn), 54 | unit 55 | end. 56 | 57 | callFFI(ServerRef, CallFn) -> 58 | fun() -> 59 | gen_server:call(ServerRef, CallFn, infinity) 60 | end. 61 | 62 | callWithTimeoutFFI(ServerRef, CallFn, Timeout) -> 63 | fun() -> 64 | gen_server:call(ServerRef, CallFn, Timeout) 65 | end. 66 | 67 | replyToFFI(From, Reply) -> 68 | fun() -> 69 | gen_server:reply(From, Reply), 70 | unit 71 | end. 72 | 73 | selfFFI() -> 74 | fun() -> 75 | self() 76 | end. 77 | 78 | stopFFI(ServerRef) -> 79 | fun() -> 80 | gen_server:stop(ServerRef), 81 | unit 82 | end. 83 | 84 | whereIs(RegistryName) -> 85 | %%---------------------------------------------------------------------------- 86 | %% This function is basically (the private) 'where' from OTP's gen.erl 87 | %%---------------------------------------------------------------------------- 88 | fun() -> 89 | RawResp = 90 | case RegistryName of 91 | {global, Name} -> global:whereis_name(Name); 92 | {via, Module, Name} -> Module:whereis_name(Name); 93 | {local, Name} -> whereis(Name) 94 | end, 95 | undefined_to_maybe(RawResp) 96 | end. 97 | 98 | %%------------------------------------------------------------------------------ 99 | %% Private functions 100 | %%------------------------------------------------------------------------------ 101 | undefined_to_maybe(undefined) -> 102 | ?nothing; 103 | undefined_to_maybe(Other) -> 104 | ?just(Other). 105 | -------------------------------------------------------------------------------- /src/Pinto/GenServer.purs: -------------------------------------------------------------------------------- 1 | -- | Module representing the gen_server in OTP 2 | -- | See also 'gen_server' in the OTP docs (https://erlang.org/doc/man/gen_server.html) 3 | module Pinto.GenServer 4 | ( InitFn 5 | , InitResult(..) 6 | , ServerSpec 7 | , ServerType 8 | , ServerPid 9 | , ServerRef(..) 10 | , CallFn 11 | , CallResult(..) 12 | , CastFn 13 | , InfoFn 14 | , TerminateFn 15 | , ContinueFn 16 | , ReturnResult(..) 17 | , From 18 | , ResultT 19 | , Context 20 | , Action(..) 21 | , defaultSpec 22 | , startLink 23 | , start 24 | , call 25 | , callWithTimeout 26 | , cast 27 | , stop 28 | , reply 29 | , replyWithAction 30 | , noReply 31 | , noReplyWithAction 32 | , return 33 | , returnWithAction 34 | , replyTo 35 | , whereIs 36 | , module ReExports 37 | , module Lift 38 | -- These probably need to go in a different module 39 | , init 40 | , handle_call 41 | , handle_cast 42 | , handle_info 43 | , handle_continue 44 | , terminate 45 | , NativeInitResult 46 | , NativeCallResult 47 | , NativeReturnResult 48 | -- these are only exported to get uncurried versions in the erlang 49 | , exportInitResult 50 | , exportCallResult 51 | , exportReturnResult 52 | ) where 53 | 54 | import Prelude 55 | 56 | import Control.Monad.Reader (ReaderT, runReaderT) 57 | import Data.Function.Uncurried (mkFn2, runFn2) 58 | import Data.Maybe (Maybe(..), fromJust) 59 | import Effect (Effect) 60 | import Effect.Class (class MonadEffect) 61 | import Effect.Class (liftEffect) as Lift 62 | import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn3, mkEffectFn1, mkEffectFn2, mkEffectFn3) 63 | import Erl.Atom (Atom, atom) 64 | import Erl.Data.List (List, head) 65 | import Erl.Data.Tuple (tuple2, tuple3, tuple4) 66 | import Erl.ModuleName (NativeModuleName, nativeModuleName) 67 | import Erl.Process (class HasProcess, getProcess, class HasSelf, Process) 68 | import Erl.Process.Raw (class HasPid, setProcessFlagTrapExit) 69 | import Erl.Types (Timeout, toErl) 70 | import Erl.Untagged.Union (class ReceivesMessage) 71 | import Foreign (Foreign, unsafeFromForeign) 72 | import Partial.Unsafe (unsafePartial) 73 | import Pinto.ModuleNames (pintoGenServer) 74 | import Pinto.Types (ExitMessage(..), RegistryInstance, RegistryName, RegistryReference, ShutdownReason, StartLinkResult, parseShutdownReasonFFI, parseTrappedExitFFI, registryInstance) 75 | import Pinto.Types (ShutdownReason(..), ExitMessage(..)) as ReExports 76 | import Unsafe.Coerce (unsafeCoerce) 77 | 78 | -- | The reader monad in which all GenServer operations take place 79 | -- | 80 | -- | - `cont` is the type that will be passed into a handle_continue callback, 81 | -- | if there is no handleContinue present, this can just be 'Unit' 82 | -- | - `stop` is the data type that can be returned with the StopOther action 83 | -- | if StopOther is not being used, then this can simply 'Unit' 84 | -- | - `msg` represents the type of message that this gen server will receive in its 85 | -- | handleInfo callback, if no messages are expected, this can simply be 'Unit' 86 | -- | - `state` represents the internal state of this GenServer, created in 'init 87 | -- | and then passed into each subsequent callback 88 | -- | - `result` is the result of any operation within a ResultT context 89 | newtype ResultT cont stop msg state result = ResultT (ReaderT (Context cont stop msg state) Effect result) 90 | 91 | derive newtype instance functorResultT :: Functor (ResultT cont stop msg state) 92 | derive newtype instance applyResultT :: Apply (ResultT cont stop msg state) 93 | derive newtype instance applicativeResultT :: Applicative (ResultT cont stop msg state) 94 | derive newtype instance bindResultT :: Bind (ResultT cont stop msg state) 95 | derive newtype instance monadResultT :: Monad (ResultT cont stop msg state) 96 | derive newtype instance monadEffectResultT :: MonadEffect (ResultT cont stop msg state) 97 | instance messageTypeResult :: ReceivesMessage (ResultT cont stop msg state) msg 98 | 99 | -- | An action to be returned to OTP 100 | -- | See {shutdown, reason}, {timeout...} etc in the gen_server documentation 101 | -- | This should be constructed and returned with the xxWithAction methods inside GenServer callbacks 102 | data Action cont stop 103 | = Timeout Int 104 | | Hibernate 105 | | Continue cont 106 | | StopNormal 107 | | StopOther stop 108 | 109 | -- | The result of a GenServer.call (handle_call) action 110 | data CallResult reply cont stop state = CallResult (Maybe reply) (Maybe (Action cont stop)) state 111 | 112 | instance mapCallResult :: Functor (CallResult reply cont stop) where 113 | map f (CallResult mReply mAction state) = CallResult mReply mAction (f state) 114 | 115 | -- | The result of a GenServer.handle_info or GenServer.handle_cast callback 116 | data ReturnResult cont stop state = ReturnResult (Maybe (Action cont stop)) state 117 | 118 | instance mapReturnResult :: Functor (ReturnResult cont stop) where 119 | map f (ReturnResult mAction state) = ReturnResult mAction (f state) 120 | 121 | -- | Creates a result from inside a GenServer 'handle_call' that results in 122 | -- | the 'reply' result being sent to the caller and the new state being stored 123 | reply :: forall reply cont stop state. reply -> state -> CallResult reply cont stop state 124 | reply theReply state = CallResult (Just theReply) Nothing state 125 | 126 | -- | Creates a result from inside a GenServer 'handle_call' that results in 127 | -- | the 'reply' result being sent to the caller , the new state being stored 128 | -- | and the attached action being returned to OTP for processing 129 | replyWithAction :: forall reply cont stop state. reply -> Action cont stop -> state -> CallResult reply cont stop state 130 | replyWithAction theReply action state = CallResult (Just theReply) (Just action) state 131 | 132 | -- | Creates a result from inside a GenServer 'handle_call' that results in 133 | -- | the new state being stored and nothing being returned to the caller (yet) 134 | noReply :: forall reply cont stop state. state -> CallResult reply cont stop state 135 | noReply state = CallResult Nothing Nothing state 136 | 137 | -- | Creates a result from inside a GenServer 'handle_call' that results in 138 | -- | the new state being stored and nothing being returned to the caller (yet) 139 | -- | and the attached action being returned to OTP for processing 140 | noReplyWithAction :: forall reply cont stop state. Action cont stop -> state -> CallResult reply cont stop state 141 | noReplyWithAction action state = CallResult Nothing (Just action) state 142 | 143 | -- | Creates a result from inside a GenServer 'handle_info/handle_cast' that results in 144 | -- | the new state being stored 145 | return :: forall cont stop state. state -> ReturnResult cont stop state 146 | return state = ReturnResult Nothing state 147 | 148 | -- | Creates a result from inside a GenServer 'handle_info/handle_cast' that results in 149 | -- | the new state being stored and the attached action being returned to OTP for processing 150 | returnWithAction :: forall cont stop state. Action cont stop -> state -> ReturnResult cont stop state 151 | returnWithAction action state = ReturnResult (Just action) state 152 | 153 | foreign import data FromForeign :: Type 154 | 155 | newtype From :: Type -> Type 156 | newtype From reply = From FromForeign 157 | 158 | -- | The callback invoked on GenServer startup: see gen_server:init 159 | type InitFn cont stop msg state = ResultT cont stop msg state (InitResult cont state) 160 | 161 | -- | The callback invoked within a GenServer.call: see gen_server:call 162 | type CallFn reply cont stop msg state = From reply -> state -> ResultT cont stop msg state (CallResult reply cont stop state) 163 | 164 | -- | The type of the handleCast callback see gen_server:cast 165 | type CastFn cont stop msg state = state -> ResultT cont stop msg state (ReturnResult cont stop state) 166 | 167 | -- | The type of the handleContinue callback see gen_server:handle_continue 168 | type ContinueFn cont stop msg state = cont -> state -> ResultT cont stop msg state (ReturnResult cont stop state) 169 | 170 | -- | The type of the handleInfo callback see gen_server:handle_info 171 | type InfoFn cont stop msg state = msg -> state -> ResultT cont stop msg state (ReturnResult cont stop state) 172 | 173 | -- | The type of the terminate callback see gen_server:terminate 174 | type TerminateFn cont stop msg state = ShutdownReason -> state -> ResultT cont stop msg state Unit 175 | 176 | -- | The various return values from an init callback 177 | -- | These roughly map onto the tuples in the OTP documentation 178 | data InitResult cont state 179 | = InitOk state 180 | | InitOkTimeout state Int 181 | | InitOkContinue state cont 182 | | InitOkHibernate state 183 | | InitStop Foreign 184 | | InitIgnore 185 | 186 | -- Can't do a functor instance over a type synonym, so just have a function instead 187 | mapInitResult :: forall state state' cont. (state -> state') -> InitResult cont state -> InitResult cont state' 188 | mapInitResult f (InitOk state) = InitOk $ f state 189 | 190 | mapInitResult f (InitOkTimeout state timeout) = InitOkTimeout (f state) timeout 191 | 192 | mapInitResult f (InitOkContinue state cont) = InitOkContinue (f state) cont 193 | 194 | mapInitResult f (InitOkHibernate state) = InitOkHibernate $ f state 195 | 196 | mapInitResult _ (InitStop term) = InitStop term 197 | 198 | mapInitResult _ InitIgnore = InitIgnore 199 | 200 | newtype ServerType :: Type -> Type -> Type -> Type -> Type 201 | newtype ServerType cont stop msg state = ServerType Void 202 | 203 | newtype ServerPid :: Type -> Type -> Type -> Type -> Type 204 | newtype ServerPid cont stop msg state = ServerPid (Process msg) 205 | 206 | derive newtype instance eqServerPid :: Eq (ServerPid cont stop msg state) 207 | derive newtype instance serverPidHasRawPid :: HasPid (ServerPid cont stop msg state) 208 | derive newtype instance serverPidHasProcess :: HasProcess msg (ServerPid const stop msg state) 209 | 210 | instance Show (ServerPid cont stop msg state) where 211 | show (ServerPid pid) = "(ServerPid " <> show pid <> ")" 212 | 213 | -- | The typed reference of a GenServer, containing all the information required to get hold of 214 | -- | an instance 215 | type ServerRef cont stop msg state = RegistryReference (ServerPid cont stop msg state) (ServerType cont stop msg state) 216 | 217 | -- | The typed instance of a GenServer, containing all the information required to call into 218 | -- | a GenServer 219 | type ServerInstance cont stop msg state = RegistryInstance (ServerPid cont stop msg state) (ServerType cont stop msg state) 220 | 221 | -- | Given a RegistryName with a valid (ServerType), get hold of a typed Process `msg` to which messages 222 | -- | can be sent (arriving in the handleInfo callback) 223 | foreign import whereIs :: forall cont stop msg state. RegistryName (ServerType cont stop msg state) -> Effect (Maybe (ServerPid cont stop msg state)) 224 | 225 | -- | The configuration passed into startLink in order to start a gen server 226 | -- | Everything except the 'init' callback is optional 227 | -- | Note: GenServers started without a name will not be callable without some means 228 | -- | of retrieving the pid 229 | type ServerSpec cont stop msg state = 230 | { name :: Maybe (RegistryName (ServerType cont stop msg state)) 231 | , init :: InitFn cont stop msg state 232 | , handleInfo :: Maybe (InfoFn cont stop msg state) 233 | , handleContinue :: Maybe (ContinueFn cont stop msg state) 234 | , terminate :: Maybe (TerminateFn cont stop msg state) 235 | , trapExits :: Maybe (ExitMessage -> msg) 236 | } 237 | 238 | -- | Given an InitFn callback, create a default GenServer specification with all of the optionals 239 | -- | set to default values 240 | -- | This is the preferred method of creating the config passed into GenServer.startLink 241 | defaultSpec :: forall cont stop msg state. InitFn cont stop msg state -> ServerSpec cont stop msg state 242 | defaultSpec initFn = 243 | { name: Nothing 244 | , init: initFn 245 | , handleInfo: Nothing 246 | , handleContinue: Nothing 247 | , terminate: Nothing 248 | , trapExits: Nothing 249 | } 250 | 251 | -- | Given a specification, starts a GenServer 252 | -- | 253 | -- | Standard usage: 254 | -- | 255 | -- | ```purescript 256 | -- | GenServer.startLink $ GenServer.defaultSpec init 257 | -- | where 258 | -- | init :: InitFn Unit Unit Unit {} 259 | -- | init = pure $ InitOk {} 260 | -- | ``` 261 | startLink :: forall cont stop msg state. (ServerSpec cont stop msg state) -> Effect (StartLinkResult (ServerPid cont stop msg state)) 262 | startLink { name: maybeName, init: initFn, handleInfo, handleContinue, terminate: terminate', trapExits } = startLinkFFI maybeName (nativeModuleName pintoGenServer) initEffect 263 | where 264 | context = 265 | Context 266 | { handleInfo 267 | , handleContinue 268 | , terminate: terminate' 269 | , trapExits 270 | } 271 | 272 | initEffect :: Effect (InitResult cont (OuterState cont stop msg state)) 273 | initEffect = do 274 | _ <- case trapExits of 275 | Nothing -> pure unit 276 | Just _ -> void $ setProcessFlagTrapExit true 277 | innerResult <- (runReaderT $ case initFn of ResultT inner -> inner) context 278 | pure $ mapInitResult (mkOuterState context) innerResult 279 | 280 | start :: forall cont stop msg state. (ServerSpec cont stop msg state) -> Effect (StartLinkResult (ServerPid cont stop msg state)) 281 | start { name: maybeName, init: initFn, handleInfo, handleContinue, terminate: terminate', trapExits } = startFFI maybeName (nativeModuleName pintoGenServer) initEffect 282 | where 283 | context = 284 | Context 285 | { handleInfo 286 | , handleContinue 287 | , terminate: terminate' 288 | , trapExits 289 | } 290 | 291 | initEffect :: Effect (InitResult cont (OuterState cont stop msg state)) 292 | initEffect = do 293 | _ <- case trapExits of 294 | Nothing -> pure unit 295 | Just _ -> void $ setProcessFlagTrapExit true 296 | innerResult <- (runReaderT $ case initFn of ResultT inner -> inner) context 297 | pure $ mapInitResult (mkOuterState context) innerResult 298 | 299 | -------------------------------------------------------------------------------- 300 | -- Internal types 301 | -------------------------------------------------------------------------------- 302 | type OuterState cont stop msg state = 303 | { innerState :: state 304 | , context :: Context cont stop msg state 305 | } 306 | 307 | mkOuterState :: forall cont stop msg state. Context cont stop msg state -> state -> OuterState cont stop msg state 308 | mkOuterState = { context: _, innerState: _ } 309 | 310 | newtype Context cont stop msg state = Context 311 | { handleInfo :: Maybe (InfoFn cont stop msg state) 312 | , handleContinue :: Maybe (ContinueFn cont stop msg state) 313 | , terminate :: Maybe (TerminateFn cont stop msg state) 314 | , trapExits :: Maybe (ExitMessage -> msg) 315 | } 316 | 317 | foreign import callFFI 318 | :: forall reply cont stop msg state 319 | . ServerInstance cont stop msg state 320 | -> CallFn reply cont stop msg state 321 | -> Effect reply 322 | 323 | call 324 | :: forall reply cont stop msg state 325 | . ServerRef cont stop msg state 326 | -> CallFn reply cont stop msg state 327 | -> Effect reply 328 | call r callFn = callFFI (registryInstance r) callFn 329 | 330 | foreign import callWithTimeoutFFI 331 | :: forall reply cont stop msg state 332 | . ServerInstance cont stop msg state 333 | -> CallFn reply cont stop msg state 334 | -> Foreign 335 | -> Effect reply 336 | 337 | callWithTimeout 338 | :: forall reply cont stop msg state 339 | . Timeout 340 | -> ServerRef cont stop msg state 341 | -> CallFn reply cont stop msg state 342 | -> Effect reply 343 | callWithTimeout timeout r callFn = callWithTimeoutFFI (registryInstance r) callFn (toErl timeout) 344 | 345 | foreign import replyToFFI :: forall reply. From reply -> reply -> Effect Unit 346 | 347 | replyTo :: forall cont stop msg state reply. From reply -> reply -> ResultT cont stop msg state Unit 348 | replyTo from reply = Lift.liftEffect $ replyToFFI from reply 349 | 350 | foreign import castFFI 351 | :: forall cont stop msg state 352 | . ServerInstance cont stop msg state 353 | -> CastFn cont stop msg state 354 | -> Effect Unit 355 | 356 | cast 357 | :: forall cont stop msg state 358 | . ServerRef cont stop msg state 359 | -> CastFn cont stop msg state 360 | -> Effect Unit 361 | cast r castFn = castFFI (registryInstance r) castFn 362 | 363 | foreign import stopFFI 364 | :: forall cont stop msg state 365 | . ServerInstance cont stop msg state 366 | -> Effect Unit 367 | 368 | stop 369 | :: forall cont stop msg state 370 | . ServerRef cont stop msg state 371 | -> Effect Unit 372 | stop r = stopFFI $ registryInstance r 373 | 374 | foreign import startLinkFFI 375 | :: forall cont stop msg state 376 | . Maybe (RegistryName (ServerType cont stop msg state)) 377 | -> NativeModuleName 378 | -> Effect (InitResult cont (OuterState cont stop msg state)) 379 | -> Effect (StartLinkResult (ServerPid cont stop msg state)) 380 | 381 | foreign import startFFI 382 | :: forall cont stop msg state 383 | . Maybe (RegistryName (ServerType cont stop msg state)) 384 | -> NativeModuleName 385 | -> Effect (InitResult cont (OuterState cont stop msg state)) 386 | -> Effect (StartLinkResult (ServerPid cont stop msg state)) 387 | 388 | instance resultT_HasSelf :: HasSelf (ResultT cont stop msg state) msg where 389 | self = do 390 | serverPid :: (ServerPid cont stop msg state) <- Lift.liftEffect selfFFI 391 | pure $ getProcess serverPid 392 | 393 | foreign import selfFFI 394 | :: forall cont stop msg state 395 | . Effect (ServerPid cont stop msg state) 396 | 397 | init 398 | :: forall cont state 399 | . EffectFn1 (List (Effect (InitResult cont state))) (NativeInitResult state) 400 | init = 401 | mkEffectFn1 \args -> do 402 | let 403 | impl = unsafePartial $ fromJust $ head args 404 | exportInitResult <$> impl 405 | 406 | handle_call :: forall reply cont stop msg state. EffectFn3 (CallFn reply cont stop msg state) (From reply) (OuterState cont stop msg state) (NativeCallResult reply cont stop (OuterState cont stop msg state)) 407 | handle_call = 408 | mkEffectFn3 \f from _state@{ innerState, context } -> do 409 | result <- (runReaderT $ case f from innerState of ResultT inner -> inner) context 410 | pure $ exportCallResult (mkOuterState context <$> result) 411 | 412 | handle_cast :: forall cont stop msg state. EffectFn2 (CastFn cont stop msg state) (OuterState cont stop msg state) (NativeReturnResult cont stop (OuterState cont stop msg state)) 413 | handle_cast = 414 | mkEffectFn2 \f _state@{ innerState, context } -> do 415 | result <- (runReaderT $ case f innerState of ResultT inner -> inner) context 416 | pure $ exportReturnResult (mkOuterState context <$> result) 417 | 418 | handle_info :: forall cont stop msg state. EffectFn2 Foreign (OuterState cont stop msg state) (NativeReturnResult cont stop (OuterState cont stop msg state)) 419 | handle_info = 420 | mkEffectFn2 \nativeMsg state@{ innerState, context: context@(Context { handleInfo: maybeHandleInfo, trapExits }) } -> 421 | exportReturnResult 422 | <$> case maybeHandleInfo of 423 | Just f -> do 424 | -------------------------------------------------------------------- 425 | -- Note we use mkFn2 for performance reasons - it's potentially very 426 | -- hot code. Similarly we manually deconstruct the Maybe to save 427 | -- using maybe' and constructing an extra (\unit -> ...) fn 428 | -------------------------------------------------------------------- 429 | let 430 | maybeClientExitMessage = trapExits <*> parseTrappedExitFFI nativeMsg Exit 431 | processMsg = 432 | mkFn2 \f msg -> do 433 | ReturnResult mAction state <- (runReaderT $ case f msg innerState of ResultT inner -> inner) context 434 | pure $ ReturnResult mAction (mkOuterState context state) 435 | case maybeClientExitMessage of 436 | Nothing -> 437 | runFn2 processMsg f $ unsafeFromForeign nativeMsg 438 | Just cem -> 439 | runFn2 processMsg f cem 440 | Nothing -> 441 | pure $ ReturnResult Nothing state 442 | 443 | terminate :: forall cont stop msg state. EffectFn2 Foreign (OuterState cont stop msg state) Atom 444 | terminate = 445 | mkEffectFn2 \reason _state@{ innerState, context: context@(Context { terminate: maybeTerminate }) } -> do 446 | case maybeTerminate of 447 | Just f -> (runReaderT $ case f (parseShutdownReasonFFI reason) innerState of ResultT inner -> inner) context 448 | Nothing -> pure unit 449 | pure $ atom "ok" 450 | 451 | handle_continue :: forall cont stop msg state. EffectFn2 cont (OuterState cont stop msg state) (NativeReturnResult cont stop (OuterState cont stop msg state)) 452 | handle_continue = 453 | mkEffectFn2 \msg state@{ innerState, context: context@(Context { handleContinue: maybeHandleContinue }) } -> 454 | exportReturnResult 455 | <$> case maybeHandleContinue of 456 | Just f -> do 457 | result <- (runReaderT $ case f msg innerState of ResultT inner -> inner) context 458 | pure $ (mkOuterState context <$> result) 459 | Nothing -> pure $ ReturnResult Nothing state 460 | 461 | exportInitResult :: forall cont state. InitResult cont state -> NativeInitResult state 462 | exportInitResult = case _ of 463 | InitStop err -> unsafeCoerce $ tuple2 (atom "stop") err 464 | InitIgnore -> unsafeCoerce $ atom "ignore" 465 | InitOk state -> unsafeCoerce $ tuple2 (atom "ok") state 466 | InitOkTimeout state timeout -> unsafeCoerce $ tuple3 (atom "timeout") state timeout 467 | InitOkContinue state cont -> unsafeCoerce $ tuple3 (atom "ok") state $ tuple2 (atom "continue") cont 468 | InitOkHibernate state -> unsafeCoerce $ tuple3 (atom "ok") state (atom "hibernate") 469 | 470 | exportCallResult :: forall reply cont stop outerState. CallResult reply cont stop outerState -> NativeCallResult reply cont stop outerState 471 | exportCallResult = case _ of 472 | CallResult (Just r) Nothing newState -> unsafeCoerce $ tuple3 (atom "reply") r newState 473 | CallResult (Just r) (Just (Timeout timeout)) newState -> unsafeCoerce $ tuple4 (atom "reply") r newState timeout 474 | CallResult (Just r) (Just Hibernate) newState -> unsafeCoerce $ tuple4 (atom "reply") r newState (atom "hibernate") 475 | CallResult (Just r) (Just (Continue cont)) newState -> unsafeCoerce $ tuple4 (atom "reply") r newState $ tuple2 (atom "continue") cont 476 | CallResult (Just r) (Just StopNormal) newState -> unsafeCoerce $ tuple4 (atom "stop") (atom "normal") r newState 477 | CallResult (Just r) (Just (StopOther reason)) newState -> unsafeCoerce $ tuple4 (atom "stop") reason r newState 478 | CallResult Nothing Nothing newState -> unsafeCoerce $ tuple2 (atom "noreply") newState 479 | CallResult Nothing (Just (Timeout timeout)) newState -> unsafeCoerce $ tuple3 (atom "noreply") newState timeout 480 | CallResult Nothing (Just Hibernate) newState -> unsafeCoerce $ tuple3 (atom "noreply") newState (atom "hibernate") 481 | CallResult Nothing (Just (Continue cont)) newState -> unsafeCoerce $ tuple3 (atom "noreply") newState $ tuple2 (atom "continue") cont 482 | CallResult Nothing (Just StopNormal) newState -> unsafeCoerce $ tuple3 (atom "stop") (atom "normal") newState 483 | CallResult Nothing (Just (StopOther reason)) newState -> unsafeCoerce $ tuple3 (atom "stop") reason newState 484 | 485 | exportReturnResult :: forall cont stop outerState. ReturnResult cont stop outerState -> NativeReturnResult cont stop outerState 486 | exportReturnResult = case _ of 487 | ReturnResult Nothing newState -> unsafeCoerce $ tuple2 (atom "noreply") newState 488 | ReturnResult (Just (Timeout timeout)) newState -> unsafeCoerce $ tuple3 (atom "noreply") newState timeout 489 | ReturnResult (Just Hibernate) newState -> unsafeCoerce $ tuple3 (atom "noreply") newState $ atom "hibernate" 490 | ReturnResult (Just (Continue cont)) newState -> unsafeCoerce $ tuple3 (atom "noreply") newState $ tuple2 (atom "continue") cont 491 | ReturnResult (Just StopNormal) newState -> unsafeCoerce $ tuple3 (atom "stop") (atom "normal") newState 492 | ReturnResult (Just (StopOther reason)) newState -> unsafeCoerce $ tuple3 (atom "stop") reason newState 493 | 494 | foreign import data NativeInitResult :: Type -> Type 495 | 496 | foreign import data NativeCallResult :: Type -> Type -> Type -> Type -> Type 497 | 498 | foreign import data NativeReturnResult :: Type -> Type -> Type -> Type 499 | -------------------------------------------------------------------------------- /src/Pinto/GenServer/ContStop.erl: -------------------------------------------------------------------------------- 1 | -module(pinto_genServer_contStop@foreign). 2 | 3 | -include_lib("kernel/include/logger.hrl"). 4 | 5 | -export([ startLinkFFI/3 6 | , startFFI/3 7 | , callFFI/2 8 | , callWithTimeoutFFI/3 9 | , castFFI/2 10 | , replyToFFI/2 11 | , stopFFI/1 12 | , whereIs/1 13 | ]). 14 | 15 | 16 | -import('pinto_types@foreign', 17 | [ start_link_result_to_ps/1 18 | ]). 19 | 20 | -define(just(A), {just, A}). 21 | -define(nothing, {nothing}). 22 | 23 | 24 | startLinkFFI(MaybeName, Module, InitEffect) -> 25 | fun() -> 26 | Result = 27 | case MaybeName of 28 | ?nothing -> 29 | gen_server:start_link(Module, [InitEffect], []); 30 | ?just(Name) -> 31 | gen_server:start_link(Name, Module, [InitEffect], []) 32 | end, 33 | 34 | start_link_result_to_ps(Result) 35 | end. 36 | 37 | startFFI(MaybeName, Module, InitEffect) -> 38 | fun() -> 39 | Result = 40 | case MaybeName of 41 | ?nothing -> 42 | gen_server:start(Module, [InitEffect], []); 43 | ?just(Name) -> 44 | gen_server:start(Name, Module, [InitEffect], []) 45 | end, 46 | 47 | start_link_result_to_ps(Result) 48 | end. 49 | 50 | castFFI(ServerRef, CastFn) -> 51 | fun() -> 52 | gen_server:cast(ServerRef, CastFn), 53 | unit 54 | end. 55 | 56 | callFFI(ServerRef, CallFn) -> 57 | fun() -> 58 | gen_server:call(ServerRef, CallFn, infinity) 59 | end. 60 | 61 | callWithTimeoutFFI(ServerRef, CallFn, Timeout) -> 62 | fun() -> 63 | gen_server:call(ServerRef, CallFn, Timeout) 64 | end. 65 | 66 | replyToFFI(From, Reply) -> 67 | fun() -> 68 | gen_server:reply(From, Reply), 69 | unit 70 | end. 71 | 72 | stopFFI(ServerRef) -> 73 | fun() -> 74 | gen_server:stop(ServerRef), 75 | unit 76 | end. 77 | 78 | whereIs(RegistryName) -> 79 | %%---------------------------------------------------------------------------- 80 | %% This function is basically (the private) 'where' from OTP's gen.erl 81 | %%---------------------------------------------------------------------------- 82 | fun() -> 83 | RawResp = 84 | case RegistryName of 85 | {global, Name} -> global:whereis_name(Name); 86 | {via, Module, Name} -> Module:whereis_name(Name); 87 | {local, Name} -> whereis(Name) 88 | end, 89 | undefined_to_maybe(RawResp) 90 | end. 91 | 92 | %%------------------------------------------------------------------------------ 93 | %% Private functions 94 | %%------------------------------------------------------------------------------ 95 | undefined_to_maybe(undefined) -> 96 | ?nothing; 97 | undefined_to_maybe(Other) -> 98 | ?just(Other). 99 | -------------------------------------------------------------------------------- /src/Pinto/GenServer/ContStop.purs: -------------------------------------------------------------------------------- 1 | -- | Module representing the gen_server in OTP 2 | -- | See also 'gen_server' in the OTP docs (https://erlang.org/doc/man/gen_server.html) 3 | 4 | module Pinto.GenServer.ContStop 5 | ( Action(..) 6 | , AllConfig 7 | , CallFn 8 | , CallResult(..) 9 | , CastFn 10 | , ContinueFn 11 | , From 12 | , GSConfig 13 | , InfoFn 14 | , InitFn 15 | , InitResult(..) 16 | , NativeCallResult 17 | , NativeInitResult 18 | , NativeReturnResult 19 | , OTPState 20 | , OptionToMaybe 21 | , OptionalConfig 22 | , ReturnResult(..) 23 | , ServerInstance 24 | , ServerPid 25 | , ServerRef 26 | , ServerType 27 | , TerminateFn 28 | , TestState 29 | , call 30 | , callWithTimeout 31 | , cast 32 | , defaultSpec 33 | , exportInitResult 34 | , exportReturnResult 35 | , handle_call 36 | , handle_cast 37 | , handle_continue 38 | , handle_info 39 | , init 40 | , noReply 41 | , noReplyWithAction 42 | , reply 43 | , replyTo 44 | , replyWithAction 45 | , return 46 | , returnWithAction 47 | , startLink 48 | , startLink' 49 | , start 50 | , start' 51 | , stop 52 | , terminate 53 | , whereIs 54 | ) where 55 | 56 | import Prelude 57 | 58 | import ConvertableOptions (class ConvertOption, class ConvertOptionsWithDefaults, convertOptionsWithDefaults) 59 | import Data.Maybe (Maybe(..), fromJust) 60 | import Data.Tuple (Tuple(..)) 61 | import Effect (Effect) 62 | import Effect.Class (class MonadEffect, liftEffect) 63 | import Effect.Uncurried (EffectFn1, EffectFn2, EffectFn3, mkEffectFn1, mkEffectFn2, mkEffectFn3) 64 | import Erl.Atom (Atom, atom) 65 | import Erl.Data.List (List, head) 66 | import Erl.Data.Tuple (tuple2, tuple3, tuple4) 67 | import Erl.ModuleName (NativeModuleName, nativeModuleName) 68 | import Erl.Process (class HasProcess, ProcessM) 69 | import Erl.Process.Raw (class HasPid) 70 | import Erl.Process.Raw as Raw 71 | import Erl.ProcessT.Internal.Types (class MonadProcessHandled, class MonadProcessRun, class MonadProcessTrans, initialise, parseForeign, run) 72 | import Erl.ProcessT.MonitorT (MonitorT) 73 | import Erl.Types (Timeout, toErl) 74 | import Foreign (Foreign) 75 | import Partial.Unsafe (unsafePartial) 76 | import Pinto.ModuleNames (pintoGenServerCS) 77 | import Pinto.Types (RegistryInstance, RegistryName, RegistryReference, ShutdownReason, StartLinkResult, parseShutdownReasonFFI, registryInstance) 78 | import Type.Prelude (Proxy(..)) 79 | import Unsafe.Coerce (unsafeCoerce) 80 | 81 | data TestState = TestState Int 82 | data TestCont = TestCont 83 | data TestStop = TestStop 84 | data TestMsg = TestMsg 85 | 86 | data TestMonitorMsg = TestMonitorMsg 87 | 88 | foreign import data FromForeign :: Type 89 | 90 | newtype From :: Type -> Type 91 | newtype From reply = From FromForeign 92 | 93 | newtype ServerPid :: Type -> Type -> Type -> (Type -> Type) -> Type 94 | newtype ServerPid cont stop state m = ServerPid Raw.Pid 95 | 96 | derive newtype instance Eq (ServerPid cont stop state m) 97 | derive newtype instance Ord (ServerPid cont stop state m) 98 | 99 | instance 100 | ( MonadProcessTrans m innerState appMsg parsedMsg 101 | ) => 102 | HasProcess appMsg (ServerPid const stop state m) where 103 | getProcess (ServerPid rawPid) = unsafeCoerce rawPid 104 | 105 | instance 106 | ( MonadProcessTrans m innerState appMsg parsedMsg 107 | , Monad m 108 | ) => 109 | HasPid (ServerPid const stop state m) where 110 | getPid = unsafeCoerce 111 | 112 | instance Show (ServerPid cont stop state m) where 113 | show (ServerPid pid) = "(ServerPid " <> show pid <> ")" 114 | 115 | -- | The typed reference of a GenServer, containing all the information required to get hold of 116 | -- | an instance 117 | type ServerRef :: Type -> Type -> Type -> (Type -> Type) -> Type 118 | type ServerRef cont stop state m = RegistryReference (ServerPid cont stop state m) (ServerType cont stop state m) 119 | 120 | -- | The typed instance of a GenServer, containing all the information required to call into 121 | -- | a GenServer 122 | type ServerInstance :: Type -> Type -> Type -> (Type -> Type) -> Type 123 | type ServerInstance cont stop state m = RegistryInstance (ServerPid cont stop state m) (ServerType cont stop state m) 124 | 125 | -- | Given a RegistryName with a valid (ServerType), get hold of a typed Process `msg` to which messages 126 | -- | can be sent (arriving in the handleInfo callback) 127 | foreign import whereIs :: forall cont stop state m. RegistryName (ServerType cont stop state m) -> Effect (Maybe (ServerPid cont stop state m)) 128 | 129 | -- | An action to be returned to OTP 130 | -- | See {shutdown, reason}, {timeout...} etc in the gen_server documentation 131 | -- | This should be constructed and returned with the xxWithAction methods inside GenServer callbacks 132 | data Action cont stop 133 | = Hibernate 134 | | Continue cont 135 | | StopNormal 136 | | StopOther stop 137 | 138 | -- | The result of a GenServer.call (handle_call) action 139 | data CallResult reply cont stop state = CallResult (Maybe reply) (Maybe (Action cont stop)) state 140 | 141 | instance mapCallResult :: Functor (CallResult reply cont stop) where 142 | map f (CallResult mReply mAction state) = CallResult mReply mAction (f state) 143 | 144 | -- | The result of a GenServer.handle_info or GenServer.handle_cast callback 145 | data ReturnResult cont stop state = ReturnResult (Maybe (Action cont stop)) state 146 | 147 | instance mapReturnResult :: Functor (ReturnResult cont stop) where 148 | map f (ReturnResult mAction state) = ReturnResult mAction (f state) 149 | 150 | -- | Creates a result from inside a GenServer 'handle_call' that results in 151 | -- | the 'reply' result being sent to the caller and the new state being stored 152 | reply :: forall reply cont stop state. reply -> state -> CallResult reply cont stop state 153 | reply theReply state = CallResult (Just theReply) Nothing state 154 | 155 | -- | Creates a result from inside a GenServer 'handle_call' that results in 156 | -- | the 'reply' result being sent to the caller , the new state being stored 157 | -- | and the attached action being returned to OTP for processing 158 | replyWithAction :: forall reply cont stop state. reply -> Action cont stop -> state -> CallResult reply cont stop state 159 | replyWithAction theReply action state = CallResult (Just theReply) (Just action) state 160 | 161 | -- | Creates a result from inside a GenServer 'handle_call' that results in 162 | -- | the new state being stored and nothing being returned to the caller (yet) 163 | noReply :: forall reply cont stop state. state -> CallResult reply cont stop state 164 | noReply state = CallResult Nothing Nothing state 165 | 166 | -- | Creates a result from inside a GenServer 'handle_call' that results in 167 | -- | the new state being stored and nothing being returned to the caller (yet) 168 | -- | and the attached action being returned to OTP for processing 169 | noReplyWithAction :: forall reply cont stop state. Action cont stop -> state -> CallResult reply cont stop state 170 | noReplyWithAction action state = CallResult Nothing (Just action) state 171 | 172 | -- | Creates a result from inside a GenServer 'handle_info/handle_cast' that results in 173 | -- | the new state being stored 174 | return :: forall cont stop state. state -> ReturnResult cont stop state 175 | return state = ReturnResult Nothing state 176 | 177 | -- | Creates a result from inside a GenServer 'handle_info/handle_cast' that results in 178 | -- | the new state being stored and the attached action being returned to OTP for processing 179 | returnWithAction :: forall cont stop state. Action cont stop -> state -> ReturnResult cont stop state 180 | returnWithAction action state = ReturnResult (Just action) state 181 | 182 | type InitFn :: Type -> Type -> (Type -> Type) -> Type 183 | type InitFn cont state m = m (InitResult cont state) 184 | 185 | type InfoFn cont stop parsedMsg state m = parsedMsg -> state -> m (ReturnResult cont stop state) 186 | type ContinueFn cont stop state m = cont -> state -> m (ReturnResult cont stop state) 187 | type CastFn cont stop state m = state -> m (ReturnResult cont stop state) 188 | type CallFn reply cont stop state m = From reply -> state -> m (CallResult reply cont stop state) 189 | type TerminateFn state m = ShutdownReason -> state -> m Unit 190 | 191 | type GSMonad = MonitorT TestMonitorMsg (ProcessM TestMsg) 192 | --type GSMonad = ProcessM TestMsg 193 | 194 | -- | The various return values from an init callback 195 | -- | These roughly map onto the tuples in the OTP documentation 196 | data InitResult cont state 197 | = InitOk state 198 | | InitOkContinue state cont 199 | | InitOkHibernate state 200 | | InitStop Foreign 201 | | InitIgnore 202 | 203 | instance Functor (InitResult cont) where 204 | map f (InitOk state) = InitOk $ f state 205 | map f (InitOkContinue state cont) = InitOkContinue (f state) cont 206 | map f (InitOkHibernate state) = InitOkHibernate $ f state 207 | map _ (InitStop term) = InitStop term 208 | map _ InitIgnore = InitIgnore 209 | 210 | newtype ServerType :: Type -> Type -> Type -> (Type -> Type) -> Type 211 | newtype ServerType cont stop state m = ServerType Void 212 | 213 | type OptionalConfig cont stop parsedMsg state m = 214 | ( serverName :: Maybe (RegistryName (ServerType cont stop state m)) 215 | , handleInfo :: Maybe (InfoFn cont stop parsedMsg state m) 216 | , handleContinue :: Maybe (ContinueFn cont stop state m) 217 | , terminate :: Maybe (TerminateFn state m) 218 | ) 219 | 220 | type AllConfig cont stop parsedMsg state m = 221 | ( init :: InitFn cont state m 222 | | OptionalConfig cont stop parsedMsg state m 223 | ) 224 | 225 | type GSConfig cont stop parsedMsg state m = 226 | { | AllConfig cont stop parsedMsg state m } 227 | 228 | data TransState 229 | data TransMsg 230 | data TransRes 231 | 232 | type Context cont stop parsedMsg state m = 233 | { handleInfo :: Maybe (InfoFn cont stop parsedMsg state m) 234 | , handleContinue :: Maybe (ContinueFn cont stop state m) 235 | , terminate :: Maybe (TerminateFn state m) 236 | , mParse :: forall a. Foreign -> a 237 | , mRun :: forall a m. m a -> TransState -> Effect (Tuple a TransState) 238 | } 239 | 240 | newtype OTPState cont stop parsedMsg state m = OTPState 241 | { innerState :: state 242 | , mState :: TransState 243 | , context :: Context cont stop parsedMsg state m 244 | } 245 | 246 | foreign import startLinkFFI 247 | :: forall cont stop parsedMsg state m 248 | . Maybe (RegistryName (ServerType cont stop state m)) 249 | -> NativeModuleName 250 | -> Effect (InitResult cont (OTPState cont stop parsedMsg state m)) 251 | -> Effect (StartLinkResult (ServerPid cont stop state m)) 252 | 253 | startLink 254 | :: forall cont stop appMsg parsedMsg state m mState 255 | . MonadProcessHandled m parsedMsg 256 | => MonadProcessRun Effect m mState appMsg parsedMsg 257 | => GSConfig cont stop parsedMsg state m 258 | -> Effect (StartLinkResult (ServerPid cont stop state m)) 259 | startLink { serverName: maybeName, init: initFn, handleInfo, handleContinue, terminate: terminate' } = startLinkFFI maybeName (nativeModuleName pintoGenServerCS) initEffect 260 | where 261 | initEffect :: Effect (InitResult cont (OTPState cont stop parsedMsg state m)) 262 | initEffect = do 263 | initialMState <- initialise (Proxy :: Proxy m) 264 | Tuple innerResult newMState <- run initFn initialMState 265 | 266 | pure $ OTPState 267 | <$> 268 | { context 269 | , mState: unsafeCoerce newMState -- TODO - add in the bug again (initialMState) and have a failing test 270 | , innerState: _ 271 | } 272 | <$> innerResult 273 | 274 | context :: Context cont stop parsedMsg state m 275 | context = 276 | { handleInfo: handleInfo 277 | , handleContinue: handleContinue 278 | , terminate: terminate' 279 | , mParse: unsafeCoerce (parseForeign :: (Foreign -> m (Maybe parsedMsg))) 280 | , mRun: unsafeCoerce (run :: forall a. m a -> mState -> Effect (Tuple a mState)) 281 | } 282 | 283 | startLink' 284 | :: forall providedConfig cont stop appMsg parsedMsg state m mState 285 | . MonadProcessHandled m parsedMsg 286 | => MonadProcessRun Effect m mState appMsg parsedMsg 287 | => ConvertOptionsWithDefaults OptionToMaybe { | OptionalConfig cont stop parsedMsg state m } { | providedConfig } { | AllConfig cont stop parsedMsg state m } 288 | => { | providedConfig } 289 | -> Effect (StartLinkResult (ServerPid cont stop state m)) 290 | startLink' providedConfig = 291 | startLink $ convertOptionsWithDefaults OptionToMaybe defaultOptions providedConfig 292 | 293 | foreign import startFFI 294 | :: forall cont stop parsedMsg state m 295 | . Maybe (RegistryName (ServerType cont stop state m)) 296 | -> NativeModuleName 297 | -> Effect (InitResult cont (OTPState cont stop parsedMsg state m)) 298 | -> Effect (StartLinkResult (ServerPid cont stop state m)) 299 | 300 | start 301 | :: forall cont stop appMsg parsedMsg state m mState 302 | . MonadProcessHandled m parsedMsg 303 | => MonadProcessRun Effect m mState appMsg parsedMsg 304 | => GSConfig cont stop parsedMsg state m 305 | -> Effect (StartLinkResult (ServerPid cont stop state m)) 306 | start { serverName: maybeName, init: initFn, handleInfo, handleContinue, terminate: terminate' } = startFFI maybeName (nativeModuleName pintoGenServerCS) initEffect 307 | where 308 | initEffect :: Effect (InitResult cont (OTPState cont stop parsedMsg state m)) 309 | initEffect = do 310 | initialMState <- initialise (Proxy :: Proxy m) 311 | Tuple innerResult newMState <- run initFn initialMState 312 | 313 | pure $ OTPState 314 | <$> 315 | { context 316 | , mState: unsafeCoerce newMState -- TODO - add in the bug again (initialMState) and have a failing test 317 | , innerState: _ 318 | } 319 | <$> innerResult 320 | 321 | context :: Context cont stop parsedMsg state m 322 | context = 323 | { handleInfo: handleInfo 324 | , handleContinue: handleContinue 325 | , terminate: terminate' 326 | , mParse: unsafeCoerce (parseForeign :: (Foreign -> m (Maybe parsedMsg))) 327 | , mRun: unsafeCoerce (run :: forall a. m a -> mState -> Effect (Tuple a mState)) 328 | } 329 | 330 | start' 331 | :: forall providedConfig cont stop appMsg parsedMsg state m mState 332 | . MonadProcessHandled m parsedMsg 333 | => MonadProcessRun Effect m mState appMsg parsedMsg 334 | => ConvertOptionsWithDefaults OptionToMaybe { | OptionalConfig cont stop parsedMsg state m } { | providedConfig } { | AllConfig cont stop parsedMsg state m } 335 | => { | providedConfig } 336 | -> Effect (StartLinkResult (ServerPid cont stop state m)) 337 | start' providedConfig = 338 | start $ convertOptionsWithDefaults OptionToMaybe defaultOptions providedConfig 339 | 340 | foreign import callFFI 341 | :: forall reply cont stop state m 342 | . ServerInstance cont stop state m 343 | -> CallFn reply cont stop state m 344 | -> Effect reply 345 | 346 | call 347 | :: forall reply cont stop appMsg parsedMsg state m mState 348 | . MonadProcessTrans m mState appMsg parsedMsg 349 | => ServerRef cont stop state m 350 | -> CallFn reply cont stop state m 351 | -> Effect reply 352 | call r callFn = callFFI (registryInstance r) callFn 353 | 354 | foreign import callWithTimeoutFFI 355 | :: forall reply cont stop state m 356 | . ServerInstance cont stop state m 357 | -> CallFn reply cont stop state m 358 | -> Foreign 359 | -> Effect reply 360 | 361 | callWithTimeout 362 | :: forall reply cont stop appMsg parsedMsg state m mState 363 | . MonadProcessTrans m mState appMsg parsedMsg 364 | => Timeout 365 | -> ServerRef cont stop state m 366 | -> CallFn reply cont stop state m 367 | -> Effect reply 368 | callWithTimeout timeout r callFn = callWithTimeoutFFI (registryInstance r) callFn (toErl timeout) 369 | 370 | foreign import castFFI 371 | :: forall cont stop state m 372 | . ServerInstance cont stop state m 373 | -> CastFn cont stop state m 374 | -> Effect Unit 375 | 376 | cast 377 | :: forall cont stop appMsg parsedMsg state m mState 378 | . MonadProcessTrans m mState appMsg parsedMsg 379 | => Monad m 380 | => ServerRef cont stop state m 381 | -> CastFn cont stop state m 382 | -> Effect Unit 383 | cast r castFn = castFFI (registryInstance r) castFn 384 | 385 | foreign import stopFFI 386 | :: forall cont stop state m 387 | . ServerInstance cont stop state m 388 | -> Effect Unit 389 | 390 | stop 391 | :: forall cont stop appMsg parsedMsg state m mState 392 | . MonadProcessTrans m mState appMsg parsedMsg 393 | => Monad m 394 | => ServerRef cont stop state m 395 | -> Effect Unit 396 | stop r = stopFFI $ registryInstance r 397 | 398 | foreign import replyToFFI :: forall reply. From reply -> reply -> Effect Unit 399 | 400 | replyTo 401 | :: forall reply m 402 | . MonadEffect m 403 | => From reply 404 | -> reply 405 | -> m Unit 406 | replyTo from reply = liftEffect $ replyToFFI from reply 407 | 408 | defaultSpec 409 | :: forall cont stop parsedMsg appMsg state m mState 410 | . MonadProcessTrans m mState appMsg parsedMsg 411 | => InitFn cont state m 412 | -> GSConfig cont stop parsedMsg state m 413 | defaultSpec initFn = 414 | { serverName: Nothing 415 | , init: initFn 416 | , handleInfo: Nothing 417 | , handleContinue: Nothing 418 | , terminate: Nothing 419 | } 420 | 421 | defaultOptions :: forall cont stop parsedMsg state m. { | OptionalConfig cont stop parsedMsg state m } 422 | defaultOptions = 423 | { serverName: Nothing 424 | , handleInfo: Nothing 425 | , handleContinue: Nothing 426 | , terminate: Nothing 427 | } 428 | 429 | data OptionToMaybe = OptionToMaybe 430 | 431 | instance ConvertOption OptionToMaybe "serverName" (Maybe a) (Maybe a) where 432 | convertOption _ _ val = val 433 | else instance ConvertOption OptionToMaybe "serverName" a (Maybe a) where 434 | convertOption _ _ val = Just val 435 | else instance ConvertOption OptionToMaybe "handleInfo" (Maybe a) (Maybe a) where 436 | convertOption _ _ val = val 437 | else instance ConvertOption OptionToMaybe "handleInfo" a (Maybe a) where 438 | convertOption _ _ val = Just val 439 | else instance ConvertOption OptionToMaybe "handleContinue" (Maybe a) (Maybe a) where 440 | convertOption _ _ val = val 441 | else instance ConvertOption OptionToMaybe "handleContinue" a (Maybe a) where 442 | convertOption _ _ val = Just val 443 | else instance ConvertOption OptionToMaybe "terminate" (Maybe a) (Maybe a) where 444 | convertOption _ _ val = val 445 | else instance ConvertOption OptionToMaybe "terminate" a (Maybe a) where 446 | convertOption _ _ val = Just val 447 | else instance ConvertOption OptionToMaybe sym a a where 448 | convertOption _ _ val = val 449 | 450 | -------------------------------------------------------------------------------- 451 | -- Underlying gen_server callback that defer to the provided monadic handlers 452 | -------------------------------------------------------------------------------- 453 | foreign import data NativeInitResult :: Type -> Type 454 | foreign import data NativeCallResult :: Type -> Type -> Type -> Type -> Type 455 | foreign import data NativeReturnResult :: Type -> Type -> Type -> Type 456 | 457 | init 458 | :: forall cont state 459 | . EffectFn1 (List (Effect (InitResult cont state))) (NativeInitResult state) 460 | init = 461 | mkEffectFn1 \args -> do 462 | let 463 | impl = unsafePartial $ fromJust $ head args 464 | exportInitResult <$> impl 465 | 466 | handle_call 467 | :: forall reply cont stop parsedMsg state m 468 | . EffectFn3 (CallFn reply cont stop state m) (From reply) (OTPState cont stop parsedMsg state m) (NativeCallResult reply cont stop (OTPState cont stop parsedMsg state m)) 469 | handle_call = 470 | mkEffectFn3 \f from otpState@(OTPState { innerState, mState, context: { mRun } }) -> do 471 | Tuple result newMState <- mRun (f from innerState) mState 472 | pure $ exportCallResult (updateOtpState otpState newMState <$> result) 473 | 474 | handle_cast 475 | :: forall cont stop parsedMsg state m 476 | . EffectFn2 (CastFn cont stop state m) (OTPState cont stop parsedMsg state m) (NativeReturnResult cont stop (OTPState cont stop parsedMsg state m)) 477 | handle_cast = 478 | mkEffectFn2 \f otpState@(OTPState { innerState, mState, context: { mRun } }) -> do 479 | Tuple result newMState <- mRun (f innerState) mState 480 | pure $ exportReturnResult (updateOtpState otpState newMState <$> result) 481 | 482 | handle_continue 483 | :: forall m cont stop parsedMsg state 484 | . EffectFn2 cont (OTPState cont stop parsedMsg state m) (NativeReturnResult cont stop (OTPState cont stop parsedMsg state m)) 485 | handle_continue = 486 | mkEffectFn2 \contMsg otpState@(OTPState { innerState, mState, context: { handleContinue: maybeHandleContinue, mRun } }) -> 487 | exportReturnResult <$> 488 | case maybeHandleContinue of 489 | Just f -> do 490 | Tuple result newMState <- mRun (f contMsg innerState) mState 491 | pure $ updateOtpState otpState newMState <$> result 492 | Nothing -> 493 | pure $ ReturnResult Nothing otpState 494 | 495 | handle_info 496 | :: forall m cont stop parsedMsg state 497 | . EffectFn2 Foreign (OTPState cont stop parsedMsg state m) (NativeReturnResult cont stop (OTPState cont stop parsedMsg state m)) 498 | handle_info = 499 | mkEffectFn2 \nativeMsg otpState@(OTPState { innerState, mState, context: { handleInfo: maybeHandleInfo, mParse, mRun } }) -> 500 | exportReturnResult <$> 501 | case maybeHandleInfo of 502 | Just f -> do 503 | Tuple mParsedMsg newMState <- mRun (mParse nativeMsg) mState 504 | case mParsedMsg of 505 | Nothing -> 506 | pure $ ReturnResult Nothing $ updateMonadState otpState newMState 507 | Just parsedMsg -> do 508 | Tuple result newMState' <- mRun (f parsedMsg innerState) newMState 509 | pure $ updateOtpState otpState newMState' <$> result 510 | Nothing -> 511 | pure $ ReturnResult Nothing otpState 512 | 513 | terminate 514 | :: forall cont stop parsedMsg state m 515 | . EffectFn2 Foreign (OTPState cont stop parsedMsg state m) Atom 516 | terminate = 517 | mkEffectFn2 \reason (OTPState { innerState, mState, context: { mRun, terminate } }) -> do 518 | case terminate of 519 | Just f -> void $ mRun (f (parseShutdownReasonFFI reason) innerState) mState 520 | Nothing -> pure unit 521 | pure $ atom "ok" 522 | 523 | -------------------------------------------------------------------------------- 524 | -- Internal 525 | -------------------------------------------------------------------------------- 526 | updateOtpState :: forall cont stop parsedMsg state m. OTPState cont stop parsedMsg state m -> TransState -> state -> OTPState cont stop parsedMsg state m 527 | updateOtpState (OTPState otpState) mState innerState = OTPState otpState { mState = mState, innerState = innerState } 528 | 529 | updateMonadState :: forall cont stop parsedMsg state m. OTPState cont stop parsedMsg state m -> TransState -> OTPState cont stop parsedMsg state m 530 | updateMonadState (OTPState otpState) mState = OTPState otpState { mState = mState } 531 | 532 | -------------------------------------------------------------------------------- 533 | -- Helpers to construct the appropriate erlang tuples from the GenServer ADTs 534 | -------------------------------------------------------------------------------- 535 | exportInitResult :: forall cont state. InitResult cont state -> NativeInitResult state 536 | exportInitResult = case _ of 537 | InitStop err -> unsafeCoerce $ tuple2 (atom "stop") err 538 | InitIgnore -> unsafeCoerce $ atom "ignore" 539 | InitOk state -> unsafeCoerce $ tuple2 (atom "ok") state 540 | InitOkContinue state cont -> unsafeCoerce $ tuple3 (atom "ok") state $ tuple2 (atom "continue") cont 541 | InitOkHibernate state -> unsafeCoerce $ tuple3 (atom "ok") state (atom "hibernate") 542 | 543 | exportReturnResult :: forall cont stop outerState. ReturnResult cont stop outerState -> NativeReturnResult cont stop outerState 544 | exportReturnResult = case _ of 545 | ReturnResult Nothing newState -> unsafeCoerce $ tuple2 (atom "noreply") newState 546 | ReturnResult (Just Hibernate) newState -> unsafeCoerce $ tuple3 (atom "noreply") newState $ atom "hibernate" 547 | ReturnResult (Just (Continue cont)) newState -> unsafeCoerce $ tuple3 (atom "noreply") newState $ tuple2 (atom "continue") cont 548 | ReturnResult (Just StopNormal) newState -> unsafeCoerce $ tuple3 (atom "stop") (atom "normal") newState 549 | ReturnResult (Just (StopOther reason)) newState -> unsafeCoerce $ tuple3 (atom "stop") reason newState 550 | 551 | exportCallResult :: forall reply cont stop outerState. CallResult reply cont stop outerState -> NativeCallResult reply cont stop outerState 552 | exportCallResult = case _ of 553 | CallResult (Just r) Nothing newState -> unsafeCoerce $ tuple3 (atom "reply") r newState 554 | CallResult (Just r) (Just Hibernate) newState -> unsafeCoerce $ tuple4 (atom "reply") r newState (atom "hibernate") 555 | CallResult (Just r) (Just (Continue cont)) newState -> unsafeCoerce $ tuple4 (atom "reply") r newState $ tuple2 (atom "continue") cont 556 | CallResult (Just r) (Just StopNormal) newState -> unsafeCoerce $ tuple4 (atom "stop") (atom "normal") r newState 557 | CallResult (Just r) (Just (StopOther reason)) newState -> unsafeCoerce $ tuple4 (atom "stop") reason r newState 558 | CallResult Nothing Nothing newState -> unsafeCoerce $ tuple2 (atom "noreply") newState 559 | CallResult Nothing (Just Hibernate) newState -> unsafeCoerce $ tuple3 (atom "noreply") newState (atom "hibernate") 560 | CallResult Nothing (Just (Continue cont)) newState -> unsafeCoerce $ tuple3 (atom "noreply") newState $ tuple2 (atom "continue") cont 561 | CallResult Nothing (Just StopNormal) newState -> unsafeCoerce $ tuple3 (atom "stop") (atom "normal") newState 562 | CallResult Nothing (Just (StopOther reason)) newState -> unsafeCoerce $ tuple3 (atom "stop") reason newState 563 | -------------------------------------------------------------------------------- /src/Pinto/GenServer2.purs: -------------------------------------------------------------------------------- 1 | -- | Module representing the gen_server in OTP 2 | -- | See also 'gen_server' in the OTP docs (https://erlang.org/doc/man/gen_server.html) 3 | 4 | module Pinto.GenServer2 5 | ( Action' 6 | , AllConfig 7 | , CallFn 8 | , CallResult' 9 | , CastFn 10 | , ContinueFn 11 | , GSConfig 12 | , InfoFn 13 | , InitFn 14 | , InitResult' 15 | , OptionalConfig 16 | , ReturnResult' 17 | , ServerInstance 18 | , ServerPid 19 | , ServerRef 20 | , ServerType 21 | , TerminateFn 22 | , call 23 | , callWithTimeout 24 | , cast 25 | , defaultSpec 26 | , replyTo 27 | , startLink 28 | , startLink' 29 | , start 30 | , start' 31 | , stop 32 | , module CSExports 33 | ) where 34 | 35 | import Prelude 36 | 37 | import ConvertableOptions (class ConvertOptionsWithDefaults) 38 | import Effect (Effect) 39 | import Effect.Class (class MonadEffect) 40 | import Erl.ProcessT.Internal.Types (class MonadProcessHandled, class MonadProcessRun, class MonadProcessTrans) 41 | import Erl.Types (Timeout) 42 | import Pinto.GenServer.ContStop (Action(Hibernate, StopNormal), InitResult(InitOk, InitOkHibernate, InitStop, InitIgnore), From, noReply, noReplyWithAction, reply, return, returnWithAction, replyWithAction) as CSExports 43 | import Pinto.GenServer.ContStop (From) 44 | import Pinto.GenServer.ContStop as CS 45 | import Pinto.Types (RegistryInstance, RegistryReference, ShutdownReason, StartLinkResult) 46 | 47 | -- In general a gen_server can return continue and stop actions but in practice they 48 | -- very rarely do. As a result the "full" interface as implemented in Pinto.GenServer.ContStop 49 | -- module is typed over cont and stop messages in addition to state and m (where m is the monad 50 | -- that the gen_server is running under and in turn dictate what messages it can receive). 51 | -- This module provides a cut down interface for gen_servers where cont and stop are both Void. 52 | -- This covers most uses cases seen in the field while cutting down on the type noise... 53 | 54 | -- | Simplified CS.ServerPid without cont and stop 55 | type ServerPid :: Type -> (Type -> Type) -> Type 56 | type ServerPid state m = CS.ServerPid Void Void state m 57 | 58 | -- | Simplified CS.ServerType without cont and stop 59 | type ServerType :: Type -> (Type -> Type) -> Type 60 | type ServerType state m = CS.ServerType Void Void state m 61 | 62 | -- | Simplified CS.ServerRef without cont and stop 63 | type ServerRef :: Type -> (Type -> Type) -> Type 64 | type ServerRef state m = RegistryReference (ServerPid state m) (ServerType state m) 65 | 66 | -- | Simplified CS.ServerInstance without cont and stop 67 | type ServerInstance :: Type -> (Type -> Type) -> Type 68 | type ServerInstance state m = RegistryInstance (ServerPid state m) (ServerType state m) 69 | 70 | -- | Simplified CS.Action without cont and stop 71 | type Action' = CS.Action Void Void 72 | 73 | -- | The various return values from an init callback 74 | -- | These roughly map onto the tuples in the OTP documentation 75 | type InitResult' state = CS.InitResult Void state 76 | 77 | -- | The result of a GenServer.call (handle_call) action 78 | type CallResult' reply state = CS.CallResult reply Void Void state 79 | 80 | -- | The result of a GenServer.handle_info or GenServer.handle_cast callback 81 | type ReturnResult' state = CS.ReturnResult Void Void state 82 | 83 | type InitFn :: forall k. Type -> (Type -> k) -> k 84 | type InitFn state m = m (InitResult' state) 85 | 86 | type InfoFn parsedMsg state m = parsedMsg -> state -> m (ReturnResult' state) 87 | type ContinueFn state m = state -> m (ReturnResult' state) 88 | type CastFn state m = state -> m (ReturnResult' state) 89 | type CallFn reply state m = From reply -> state -> m (CallResult' reply state) 90 | type TerminateFn state m = ShutdownReason -> state -> m Unit 91 | 92 | type OptionalConfig parsedMsg state m = CS.OptionalConfig Void Void parsedMsg state m 93 | type AllConfig parsedMsg state m = CS.AllConfig Void Void parsedMsg state m 94 | type GSConfig parsedMsg state m = CS.GSConfig Void Void parsedMsg state m 95 | 96 | startLink 97 | :: forall appMsg parsedMsg state m mState 98 | . MonadProcessHandled m parsedMsg 99 | => MonadProcessRun Effect m mState appMsg parsedMsg 100 | => GSConfig parsedMsg state m 101 | -> Effect (StartLinkResult (ServerPid state m)) 102 | startLink = CS.startLink 103 | 104 | startLink' 105 | :: forall providedConfig appMsg parsedMsg state m mState 106 | . MonadProcessHandled m parsedMsg 107 | => MonadProcessRun Effect m mState appMsg parsedMsg 108 | => ConvertOptionsWithDefaults CS.OptionToMaybe { | OptionalConfig parsedMsg state m } { | providedConfig } { | AllConfig parsedMsg state m } 109 | => { | providedConfig } 110 | -> Effect (StartLinkResult (ServerPid state m)) 111 | startLink' = CS.startLink' 112 | 113 | start 114 | :: forall appMsg parsedMsg state m mState 115 | . MonadProcessHandled m parsedMsg 116 | => MonadProcessRun Effect m mState appMsg parsedMsg 117 | => GSConfig parsedMsg state m 118 | -> Effect (StartLinkResult (ServerPid state m)) 119 | start = CS.start 120 | 121 | start' 122 | :: forall providedConfig appMsg parsedMsg state m mState 123 | . MonadProcessHandled m parsedMsg 124 | => MonadProcessRun Effect m mState appMsg parsedMsg 125 | => ConvertOptionsWithDefaults CS.OptionToMaybe { | OptionalConfig parsedMsg state m } { | providedConfig } { | AllConfig parsedMsg state m } 126 | => { | providedConfig } 127 | -> Effect (StartLinkResult (ServerPid state m)) 128 | start' = CS.start' 129 | 130 | call 131 | :: forall reply appMsg parsedMsg state m mState 132 | . MonadProcessHandled m parsedMsg 133 | => MonadProcessTrans m mState appMsg parsedMsg 134 | => ServerRef state m 135 | -> CallFn reply state m 136 | -> Effect reply 137 | call = CS.call 138 | 139 | callWithTimeout 140 | :: forall reply appMsg parsedMsg state m mState 141 | . MonadProcessHandled m parsedMsg 142 | => MonadProcessTrans m mState appMsg parsedMsg 143 | => Timeout 144 | -> ServerRef state m 145 | -> CallFn reply state m 146 | -> Effect reply 147 | callWithTimeout = CS.callWithTimeout 148 | 149 | cast 150 | :: forall appMsg parsedMsg state m mState 151 | . MonadProcessHandled m parsedMsg 152 | => MonadProcessTrans m mState appMsg parsedMsg 153 | => Monad m 154 | => ServerRef state m 155 | -> CastFn state m 156 | -> Effect Unit 157 | cast = CS.cast 158 | 159 | stop 160 | :: forall appMsg parsedMsg state m mState 161 | . MonadProcessHandled m parsedMsg 162 | => MonadProcessTrans m mState appMsg parsedMsg 163 | => Monad m 164 | => ServerRef state m 165 | -> Effect Unit 166 | stop = CS.stop 167 | 168 | replyTo 169 | :: forall reply m 170 | . MonadEffect m 171 | => From reply 172 | -> reply 173 | -> m Unit 174 | replyTo = CS.replyTo 175 | 176 | defaultSpec 177 | :: forall parsedMsg appMsg state m mState 178 | . MonadProcessHandled m parsedMsg 179 | => MonadProcessTrans m mState appMsg parsedMsg 180 | => InitFn state m 181 | -> GSConfig parsedMsg state m 182 | defaultSpec = CS.defaultSpec 183 | -------------------------------------------------------------------------------- /src/Pinto/GenStatem.erl: -------------------------------------------------------------------------------- 1 | -module(pinto_genStatem@foreign). 2 | 3 | -include_lib("kernel/include/logger.hrl"). 4 | 5 | %% FFI Exports 6 | -export([ startLinkFFI/3 7 | , procLibStartLinkFFI/3 8 | , selfFFI/0 9 | , callFFI/2 10 | , castFFI/2 11 | , reply/1 12 | , parseEventFFI/3 13 | ]). 14 | 15 | -import('pinto_types@foreign', 16 | [ start_link_result_to_ps/1 17 | ]). 18 | 19 | %%% ---------------------------------------------------------------------------- 20 | %%% Directly Exported FFI 21 | %%% ---------------------------------------------------------------------------- 22 | reply(To) -> 23 | fun(Reply) -> 24 | {reply, To, Reply} 25 | end. 26 | 27 | %%% ---------------------------------------------------------------------------- 28 | %%% FFI API 29 | %%% ---------------------------------------------------------------------------- 30 | startLinkFFI(MaybeName, Module, Spec) -> 31 | fun() -> 32 | Result = 33 | case MaybeName of 34 | {nothing} -> 35 | gen_statem:start_link(Module, Spec, []); 36 | {just, Name} -> 37 | gen_statem:start_link(Name, Module, Spec, []) 38 | end, 39 | 40 | start_link_result_to_ps(Result) 41 | end. 42 | 43 | procLibStartLinkFFI(MaybeName, Module, Spec) -> 44 | fun() -> 45 | Pid = proc_lib:spawn_link(fun() -> 46 | Name = case MaybeName of 47 | {nothing} -> self(); 48 | {just, JustName} -> JustName 49 | end, 50 | case register_name(Name) of 51 | true -> 52 | Result = case Module:init(Spec) of 53 | {ok, State, Data} -> 54 | {ok, State, Data, []}; 55 | {ok, State, Data, Actions} -> 56 | {ok, State, Data, Actions}; 57 | Other -> 58 | Other 59 | end, 60 | 61 | case Result of 62 | {ok, State2, Data2, Actions2} -> 63 | gen_statem:enter_loop(Module, [], State2, Data2, Name, Actions2); 64 | {stop, Reason} -> 65 | {error, Reason}; 66 | ignore -> 67 | ok 68 | end; 69 | {false, Pid} -> 70 | {error, {already_started, Pid}} 71 | end 72 | end), 73 | {right, Pid} 74 | end. 75 | 76 | callFFI(StatemRef, CallFn) -> 77 | fun() -> 78 | gen_server:call(StatemRef, CallFn, infinity) 79 | end. 80 | 81 | castFFI(StatemRef, CastFn) -> 82 | fun() -> 83 | ok = gen_server:cast(StatemRef, CastFn), 84 | unit 85 | end. 86 | 87 | selfFFI() -> 88 | fun() -> 89 | self() 90 | end. 91 | 92 | parseEventFFI(T, TE, E) -> 93 | case T of 94 | { call, From } -> {handleEventCall, From, E}; 95 | cast -> {handleEventCast, E}; 96 | enter -> {handleEventEnter, E}; 97 | _Event -> {handleEvent, event_to_ps(T, TE, E)} 98 | end. 99 | 100 | event_to_ps(info, TE, Info) -> {eventInfo, TE(Info)}; 101 | event_to_ps(internal,_, Internal) -> {eventInternal, Internal}; 102 | event_to_ps(timeout, _, Content) -> {eventTimeout, Content}; 103 | event_to_ps({timeout, Name}, _, Content) -> {eventNamedTimeout, Name, Content}; 104 | event_to_ps(state_timeout,_, Content) -> {eventStateTimeout, Content}. 105 | 106 | 107 | where({global, Name}) -> global:whereis_name(Name); 108 | where({via, Module, Name}) -> Module:whereis_name(Name); 109 | where({local, Name}) -> whereis(Name). 110 | 111 | register_name(Pid) when is_pid(Pid) -> 112 | true; 113 | register_name({local, Name} = LN) -> 114 | try register(Name, self()) of 115 | true -> true 116 | catch 117 | error:_ -> 118 | {false, where(LN)} 119 | end; 120 | register_name({global, Name} = GN) -> 121 | case global:register_name(Name, self()) of 122 | yes -> true; 123 | no -> {false, where(GN)} 124 | end; 125 | register_name({via, Module, Name} = GN) -> 126 | case Module:register_name(Name, self()) of 127 | yes -> 128 | true; 129 | no -> 130 | {false, where(GN)} 131 | end. 132 | -------------------------------------------------------------------------------- /src/Pinto/MessageRouting.erl: -------------------------------------------------------------------------------- 1 | -module(pinto_messageRouting@foreign). 2 | 3 | -export([ startRouterImpl/5 4 | , maybeStartRouterImpl/5 5 | , stopRouter/1 6 | , stopRouterFromCallback/0 7 | ]). 8 | 9 | %% RegisterListener is of type Effect msg (so is effectively a function with no args) 10 | %% DeregisterListener is of type (msg -> Effect Unit) and takes this value and gives us an Effect 11 | %% with which we will need to invoke manually here 12 | startRouterImpl(Ref, RegisterListener, DeregisterListener, Callback, State) -> 13 | fun() -> 14 | {just, Result } = (maybeStartRouterImpl(Ref, fun() -> { just, RegisterListener() } end, DeregisterListener, Callback, State))(), 15 | Result 16 | end. 17 | 18 | maybeStartRouterImpl(Ref, RegisterListener, DeregisterListener, Callback, State) -> 19 | Recipient = self(), 20 | Fun = fun Fun(Handle, MonitorRef, InnerState) -> 21 | receive 22 | {stop, From, StopRef} -> 23 | ((DeregisterListener(InnerState))(Handle))(), 24 | demonitor(MonitorRef), 25 | From ! {stopped, StopRef}, 26 | exit(normal); 27 | {'DOWN', MonitorRef, _, _, _} -> 28 | ((DeregisterListener(InnerState))(Handle))(), 29 | exit(normal); 30 | Msg -> 31 | InnerState2 = try 32 | ((Callback(InnerState))(Msg))() 33 | catch 34 | Class:Reason:Stack -> 35 | Recipient ! {error, {message_router_callback_failed, {Class, Reason, Stack}}}, 36 | exit(error) 37 | end, 38 | Fun(Handle, MonitorRef, InnerState2) 39 | end 40 | end, 41 | fun() -> 42 | {Pid, MonitorRef} = spawn_monitor(fun() -> 43 | MaybeHandle = RegisterListener(), 44 | case MaybeHandle of 45 | {just, Handle} -> 46 | Recipient ! { start_result, Handle }, 47 | MonitorRef = monitor(process, Recipient), 48 | Fun(Handle, MonitorRef, State); 49 | {nothing} -> 50 | Recipient ! { start_result, undefined } 51 | end 52 | end), 53 | receive 54 | {'DOWN', MonitorRef, _, _, _} -> 55 | {nothing}; 56 | { start_result, undefined } -> 57 | erlang:demonitor(MonitorRef, [flush]), 58 | {nothing}; 59 | { start_result, Result } -> 60 | erlang:demonitor(MonitorRef, [flush]), 61 | {just, (Ref(Result))(Pid) } 62 | end 63 | end. 64 | 65 | stopRouterFromCallback() -> 66 | Self = self(), 67 | fun() -> 68 | Ref = make_ref(), 69 | Self ! {stop, self(), Ref}, 70 | ok 71 | end. 72 | 73 | stopRouter({_, _, Pid}) -> 74 | fun() -> 75 | Ref = make_ref(), 76 | MRef = erlang:monitor(process, Pid), 77 | Pid ! {stop, self(), Ref}, 78 | receive 79 | {stopped, Ref} -> ok; 80 | {'DOWN', MRef, _, _, _} -> ok 81 | end, 82 | erlang:demonitor(MRef, [flush]), 83 | ok 84 | end. 85 | -------------------------------------------------------------------------------- /src/Pinto/MessageRouting.purs: -------------------------------------------------------------------------------- 1 | -- | This module is designed to wrap legacy APIs that send messages back to the 2 | -- | invoking process, instead of receiving arbitrary types directly, this gives us a chance 3 | -- | to intercept the legacy messages and lift them into an appropriate type for the current context 4 | module Pinto.MessageRouting 5 | ( startRouter 6 | , maybeStartRouter 7 | , stopRouterFromCallback 8 | , stopRouter 9 | , RouterRef(..) 10 | ) where 11 | 12 | import Prelude 13 | import Data.Maybe (Maybe) 14 | import Effect (Effect) 15 | import Erl.Process.Raw (Pid) 16 | 17 | -- | Reference to a running router 18 | -- | 19 | -- | - `handle` is the value returned by the start mechanism of the worker 20 | data RouterRef handle = RouterRef handle Pid 21 | 22 | -- | Given an `Effect handle`, runs that effect in a new process, returning a RouterRef for that new process 23 | -- | 24 | -- | The `(handle -> Effect Unit)` parameter will be invoked when the router is stopped 25 | -- | and the `(msg -> Effect Unit)` parameter will be invoked whenever a message is received by the router 26 | startRouter :: forall handle state msg. Effect handle -> (state -> handle -> Effect Unit) -> (state -> msg -> Effect state) -> state -> Effect (RouterRef handle) 27 | startRouter = startRouterImpl RouterRef 28 | 29 | -- | Given an `Effect (Maybe handle)`, run that effect in a new process. If the effect returns Nothing, the process is terminated 30 | -- | else, a `RouterRef handle` is returned 31 | maybeStartRouter :: forall handle state msg. Effect (Maybe handle) -> (state -> handle -> Effect Unit) -> (state -> msg -> Effect state) -> state -> Effect (Maybe (RouterRef handle)) 32 | maybeStartRouter = maybeStartRouterImpl RouterRef 33 | 34 | -- | Terminates a router by invoking the 'stop' mechanism registered when the router was first started with the 35 | -- | `handle` that was returned by the initial Effect 36 | foreign import stopRouter :: forall handle. RouterRef handle -> Effect Unit 37 | 38 | -- | Instantly terminates a router from within a callback (such as `msg -> Effect Unit`) without access to the handle 39 | -- | 40 | -- | Note: This should only be called from within that callback as it results in a message being sent to the current process 41 | foreign import stopRouterFromCallback :: Effect Unit 42 | 43 | foreign import startRouterImpl :: forall handle state msg. (handle -> Pid -> RouterRef handle) -> Effect handle -> (state -> handle -> Effect Unit) -> (state -> msg -> Effect state) -> state -> Effect (RouterRef handle) 44 | 45 | foreign import maybeStartRouterImpl :: forall handle state msg. (handle -> Pid -> RouterRef handle) -> Effect (Maybe handle) -> (state -> handle -> Effect Unit) -> (state -> msg -> Effect state) -> state -> Effect (Maybe (RouterRef handle)) 46 | -------------------------------------------------------------------------------- /src/Pinto/ModuleNames.purs: -------------------------------------------------------------------------------- 1 | module Pinto.ModuleNames where 2 | 3 | import Erl.ModuleName (ModuleName(..)) 4 | 5 | pintoApp :: ModuleName 6 | pintoApp = ModuleName "Pinto.App" 7 | 8 | pintoGenServer :: ModuleName 9 | pintoGenServer = ModuleName "Pinto.GenServer" 10 | 11 | pintoGenServerCS :: ModuleName 12 | pintoGenServerCS = ModuleName "Pinto.GenServer.ContStop" 13 | 14 | pintoGenStatem :: ModuleName 15 | pintoGenStatem = ModuleName "Pinto.GenStatem" 16 | 17 | pintoMessageRouting :: ModuleName 18 | pintoMessageRouting = ModuleName "Pinto.MessageRouting" 19 | 20 | pintoModuleNames :: ModuleName 21 | pintoModuleNames = ModuleName "Pinto.ModuleNames" 22 | 23 | pintoMonitor :: ModuleName 24 | pintoMonitor = ModuleName "Pinto.Monitor" 25 | 26 | pintoSup :: ModuleName 27 | pintoSup = ModuleName "Pinto.Sup" 28 | 29 | pintoTypes :: ModuleName 30 | pintoTypes = ModuleName "Pinto.Types" 31 | -------------------------------------------------------------------------------- /src/Pinto/Monitor.erl: -------------------------------------------------------------------------------- 1 | -module(pinto_monitor@foreign). 2 | 3 | -export([ startMonitor/1 4 | , stopMonitor/1 5 | , handleMonitorMessage/3 6 | ]). 7 | 8 | startMonitor(Pid) -> 9 | fun() -> 10 | erlang:monitor(process, Pid) 11 | end. 12 | 13 | stopMonitor(Ref) -> 14 | fun() -> 15 | erlang:demonitor(Ref) 16 | end. 17 | 18 | %% Note: The client of this monitor code gets a RouterRef 19 | %% which is just a new typed pid of the worker process in the message router 20 | %% so 'self' suffices for identifying which monitor is invoking the callback 21 | %% although given the presence of the callback, it would probably be more prudent 22 | %% to simply load context into that as a partially applied fn 23 | handleMonitorMessage(Wrapper, Callback, {'DOWN', _MonitorRef, MonitorType, MonitorObject, MonitorInfo}) -> 24 | fun() -> 25 | Msg = (((Wrapper(self()))({MonitorType}))(MonitorObject))(MonitorInfo), 26 | (Callback(Msg))() 27 | end. 28 | -------------------------------------------------------------------------------- /src/Pinto/Monitor.purs: -------------------------------------------------------------------------------- 1 | -- | This module wraps erlang:monitor in `Pinto.MessageRouting` so that sensible message structures can be sent 2 | -- | back to the monitoring process 3 | module Pinto.Monitor 4 | ( monitor 5 | , monitorTo 6 | , demonitor 7 | , MonitorMsg(..) 8 | , MonitorType(..) 9 | , MonitorRef 10 | , MonitorObject 11 | , MonitorInfo 12 | ) where 13 | 14 | import Prelude 15 | import Effect (Effect) 16 | import Effect.Class (class MonadEffect, liftEffect) 17 | import Foreign (Foreign) 18 | import Pinto.MessageRouting as MR 19 | import Erl.Process.Raw (Pid, class HasPid, getPid) 20 | import Erl.Process (class HasSelf, send, self, class HasProcess, getProcess) 21 | 22 | -- | Reference to a monitor, used to stop the monitor once it is started 23 | foreign import data MonitorRef :: Type 24 | 25 | -- | This is probably a Pid, but until it is needed it will be Foreign 26 | type MonitorObject = Foreign 27 | 28 | -- | The 'reason' for the monitor being invoked, if this needs unpacking 29 | -- | then FFI will need to be written 30 | type MonitorInfo = Foreign 31 | 32 | -- | The type of monitor this message is being sent on behalf 33 | data MonitorType 34 | = Process 35 | | Port 36 | 37 | -- | Reference to a monitor, used to stop the monitor once it is started 38 | data MonitorMsg = Down (MR.RouterRef MonitorRef) MonitorType MonitorObject MonitorInfo 39 | 40 | -- | Given something that has a pid (A GenServer, a Process.. or just a Pid), attach a monitor by using 41 | -- | erlang:monitor on the underlying pid, a message will be sent to the current process, lifted into the 42 | -- | constructor `f` provided 43 | monitor 44 | :: forall msg process m 45 | . HasPid process 46 | => MonadEffect m 47 | => HasSelf m msg 48 | => process 49 | -> (MonitorMsg -> msg) 50 | -> m (MR.RouterRef MonitorRef) 51 | monitor process f = do 52 | me <- self 53 | liftEffect $ MR.startRouter (startMonitor $ getPid process) (\_ -> stopMonitor) (handleMessage me) unit 54 | where 55 | handleMessage me _ msg = do 56 | _ <- handleMonitorMessage Down (send me <<< f) msg 57 | _ <- MR.stopRouterFromCallback 58 | pure unit 59 | 60 | -- | Given something that has a pid (A GenServer, a Process.. or just a Pid), attach a monitor by using 61 | -- | erlang:monitor on the underlying pid, a message will be sent to the current process, lifted into the 62 | -- | constructor `f` provided 63 | monitorTo 64 | :: forall msg process target 65 | . HasPid process 66 | => HasProcess msg target 67 | => process 68 | -> target 69 | -> (MonitorMsg -> msg) 70 | -> Effect (MR.RouterRef MonitorRef) 71 | monitorTo process target f = do 72 | let p = getProcess target 73 | MR.startRouter (startMonitor $ getPid process) (\_ -> stopMonitor) (handleMessage p) unit 74 | where 75 | handleMessage target' _ msg = do 76 | _ <- handleMonitorMessage Down (send target' <<< f) msg 77 | _ <- MR.stopRouterFromCallback 78 | pure unit 79 | 80 | -- | Stops a monitor started with Monitor.monitor, using erlang:demonitor and subject to the same restrictions/caveats 81 | demonitor :: MR.RouterRef MonitorRef -> Effect Unit 82 | demonitor = MR.stopRouter 83 | 84 | foreign import startMonitor :: Pid -> Effect MonitorRef 85 | foreign import stopMonitor :: MonitorRef -> Effect Unit 86 | 87 | foreign import handleMonitorMessage 88 | :: forall msg 89 | . (MR.RouterRef MonitorRef -> MonitorType -> MonitorObject -> MonitorInfo -> MonitorMsg) 90 | -> (MonitorMsg -> Effect Unit) 91 | -> msg 92 | -> Effect Unit 93 | -------------------------------------------------------------------------------- /src/Pinto/Supervisor.erl: -------------------------------------------------------------------------------- 1 | -module(pinto_supervisor@foreign). 2 | 3 | %%------------------------------------------------------------------------------ 4 | %% FFI API 5 | %%------------------------------------------------------------------------------ 6 | -export([ specFFI/1 7 | , startLink/2 8 | , stopFFI/2 9 | , startChildFFI/2 10 | , terminateChildFFI/2 11 | , deleteChildFFI/2 12 | ]). 13 | 14 | 15 | %%------------------------------------------------------------------------------ 16 | %% Runtime supervisor stubs 17 | %%------------------------------------------------------------------------------ 18 | -export([ start_proxy/1 19 | , init/1 20 | ]). 21 | 22 | %% used by dynamic sup 23 | -export([ restart_from_ps/1, 24 | shutdown_from_ps/1, 25 | type_from_ps/1 26 | ]). 27 | 28 | -purs_ignore_exports([start_proxy/1, init/1, restart_from_ps/1, shutdown_from_ps/1, type_from_ps/1]). 29 | 30 | -import('pinto_types@foreign', 31 | [ start_link_result_to_ps/1 32 | , start_link_result_from_ps/1 33 | ]). 34 | 35 | init(EffectSupervisorSpec) -> 36 | #{ flags := Flags 37 | , childSpecs := ChildSpecs 38 | } = EffectSupervisorSpec(), 39 | 40 | {ok, {flags_from_ps(Flags), ChildSpecs}}. 41 | 42 | 43 | %%------------------------------------------------------------------------------ 44 | %% FFI API 45 | %%------------------------------------------------------------------------------ 46 | specFFI(#{ id := ChildId 47 | , start := StartFn 48 | , restartStrategy := RestartStrategy 49 | , shutdownStrategy := ChildShutdownTimeoutStrategy 50 | , childType := ChildType 51 | }) -> 52 | #{ id => ChildId 53 | , start => {?MODULE, start_proxy, [StartFn]} 54 | , restart => restart_from_ps(RestartStrategy) 55 | , shutdown => shutdown_from_ps(ChildShutdownTimeoutStrategy) 56 | , type => type_from_ps(ChildType) 57 | }. 58 | 59 | 60 | startLink(Name, EffectSupervisorSpec) -> 61 | fun() -> 62 | startLinkPure(Name, EffectSupervisorSpec) 63 | end. 64 | 65 | startLinkPure({nothing}, EffectSupervisorSpec) -> 66 | Result = supervisor:start_link(?MODULE, EffectSupervisorSpec), 67 | start_link_result_to_ps(Result); 68 | startLinkPure({just, Name}, EffectSupervisorSpec) -> 69 | Result = supervisor:start_link(Name, ?MODULE, EffectSupervisorSpec), 70 | start_link_result_to_ps(Result). 71 | 72 | stopFFI(Timeout, RefOrPid) -> 73 | fun() -> 74 | gen:stop(RefOrPid, normal, case Timeout of {stopInfinity} -> infinity; {stopTimeout, Ms} -> trunc(Ms) end) 75 | end. 76 | 77 | startChildFFI(Ref, ChildSpec) -> 78 | fun() -> 79 | Result = supervisor:start_child(Ref, ChildSpec), 80 | start_child_result_to_ps(Result) 81 | end. 82 | 83 | terminateChildFFI(Ref, Id) -> 84 | fun() -> 85 | Result = supervisor:terminate_child(Ref, Id), 86 | terminate_child_result_to_ps(Result) 87 | end. 88 | 89 | deleteChildFFI(Ref, Id) -> 90 | fun() -> 91 | Result = supervisor:delete_child(Ref, Id), 92 | delete_child_result_to_ps(Result) 93 | end. 94 | 95 | %%------------------------------------------------------------------------------ 96 | %% erlang -> ps conversion helpers 97 | %%------------------------------------------------------------------------------ 98 | start_child_result_to_ps({ok, undefined}) -> {childStartReturnedIgnore}; 99 | start_child_result_to_ps({ok, {Pid, Info}}) -> {childStarted, #{pid => Pid, info => {just, Info}}}; 100 | start_child_result_to_ps({ok, Pid}) -> {childStarted, #{pid => Pid, info => {nothing}}}; 101 | start_child_result_to_ps({error, already_present}) -> {childAlreadyPresent}; 102 | start_child_result_to_ps({error, {already_started, Pid}}) -> {childAlreadyStarted, Pid}; 103 | start_child_result_to_ps({error, Other}) -> {childFailed, Other}. 104 | 105 | %% These are deliberately not exhaustive, as this code path shouldn't be hit with simple_one_for_one 106 | delete_child_result_to_ps(ok) -> {childDeleted}; 107 | delete_child_result_to_ps({error, running}) -> {childRunning}; 108 | delete_child_result_to_ps({error, not_found}) -> {childNotFoundToDelete}. 109 | 110 | terminate_child_result_to_ps(ok) -> {childTerminated}; 111 | terminate_child_result_to_ps({error, not_found}) -> {childNotFoundToTerminate}. 112 | 113 | %%------------------------------------------------------------------------------ 114 | %% ps -> erlang conversion helpers 115 | %%------------------------------------------------------------------------------ 116 | flags_from_ps( #{ strategy := Strategy 117 | , intensity := Intensity 118 | , period := Period 119 | }) -> 120 | #{ strategy => strategy_from_ps(Strategy) 121 | , intensity => Intensity 122 | , period => round(Period) 123 | }. 124 | 125 | %% Note: These could be done in Purerl too and next time we're down thie way, probably will be 126 | 127 | strategy_from_ps({oneForAll}) -> one_for_all; 128 | strategy_from_ps({oneForOne}) -> one_for_one; 129 | strategy_from_ps({restForOne}) -> rest_for_one. 130 | 131 | restart_from_ps({restartTransient}) -> transient; 132 | restart_from_ps({restartPermanent}) -> permanent; 133 | restart_from_ps({restartTemporary}) -> temporary. 134 | 135 | shutdown_from_ps({shutdownBrutal}) -> brutal; 136 | shutdown_from_ps({shutdownInfinity}) -> infinity; 137 | shutdown_from_ps({shutdownTimeout, Ms}) -> round(Ms). 138 | 139 | type_from_ps({supervisor}) -> supervisor; 140 | type_from_ps({worker}) -> worker. 141 | 142 | start_proxy(StartEffect) -> 143 | StartResult = StartEffect(), 144 | start_link_result_from_ps(StartResult). 145 | -------------------------------------------------------------------------------- /src/Pinto/Supervisor.purs: -------------------------------------------------------------------------------- 1 | -- | This module represents supervisor in OTP 2 | -- | See also gen_supervisor in the OTP docs (https://erlang.org/doc/man/supervisor.html#) 3 | module Pinto.Supervisor 4 | ( ChildShutdownTimeoutStrategy(..) 5 | , ChildSpec(..) 6 | , ChildType(..) 7 | , ChildNotStartedReason(..) 8 | , StartChildResult(..) 9 | , ErlChildSpec 10 | , Flags 11 | , RestartStrategy(..) 12 | , StopTimeoutStrategy(..) 13 | , Strategy(..) 14 | , SupervisorSpec 15 | , SupervisorRef(..) 16 | , SupervisorPid 17 | , SupervisorType 18 | , TerminateChildResult(..) 19 | , DeleteChildResult(..) 20 | , spec 21 | , startLink 22 | , startChild 23 | , terminateChild 24 | , deleteChild 25 | , stop 26 | , maybeChildStarted 27 | , maybeChildRunning 28 | , crashIfChildNotStarted 29 | , crashIfChildNotRunning 30 | ) where 31 | 32 | import Prelude 33 | import Data.Maybe (Maybe(..)) 34 | import Data.Time.Duration (Milliseconds, Seconds) 35 | import Effect (Effect) 36 | import Erl.Data.List (List) 37 | import Erl.Process.Raw (Pid, class HasPid) 38 | import Foreign (Foreign) 39 | import Partial.Unsafe (unsafePartial) 40 | import Pinto.Types (RegistryInstance, RegistryName, RegistryReference, StartLinkResult, registryInstance) 41 | 42 | data ChildNotStartedReason :: Type -> Type 43 | data ChildNotStartedReason childProcess 44 | 45 | data StartChildResult childProcess 46 | = ChildAlreadyPresent 47 | | ChildAlreadyStarted childProcess 48 | | ChildStartReturnedIgnore 49 | | ChildFailed Foreign 50 | | ChildStarted 51 | { pid :: childProcess 52 | , info :: Maybe Foreign 53 | } 54 | 55 | data DeleteChildResult 56 | = ChildDeleted 57 | | ChildNotFoundToDelete 58 | 59 | data TerminateChildResult 60 | = ChildTerminated 61 | | ChildNotFoundToTerminate 62 | 63 | -- | This maps to transient | permanent | temporary as per the underlying supervisor API 64 | data RestartStrategy 65 | = RestartTransient 66 | | RestartPermanent 67 | | RestartTemporary 68 | 69 | -- | This maps to brutal | infinity | { timeout, Milliseconds } as per the underlying supervisor API 70 | data ChildShutdownTimeoutStrategy 71 | = ShutdownBrutal 72 | | ShutdownInfinity 73 | | ShutdownTimeout Milliseconds 74 | 75 | -- | This maps to supervisor | worker as per the underlying supervisor API 76 | data ChildType 77 | = Supervisor 78 | | Worker 79 | 80 | -- | The specification of a child process, this maps to ChildSpec in the underlying supervisor API 81 | -- | with the difference that none of them are optional. 82 | -- | 83 | -- | `childProcess` is the typed pid of the started process (commonly GenServer.ServerPid) 84 | type ChildSpec childProcess = 85 | { id :: String 86 | , start :: Effect (StartLinkResult childProcess) 87 | , restartStrategy :: RestartStrategy 88 | , shutdownStrategy :: ChildShutdownTimeoutStrategy 89 | , childType :: ChildType 90 | } 91 | 92 | -- | The strategy employed by this supervision tree, this maps to 93 | -- | one_for_all | one_for_one | rest_for_one in the underlying supervisor API 94 | -- | 95 | -- | Note: simple_one_for_one is deliberately missing, see: `Supervisor.SimpleOneForOne` 96 | data Strategy 97 | = OneForAll 98 | | OneForOne 99 | | RestForOne 100 | 101 | -- | The flags for a supervision tree, mapping onto sup_flags from the underlying supervisor API 102 | type Flags = 103 | { strategy :: Strategy 104 | , intensity :: Int 105 | , period :: Seconds 106 | } 107 | 108 | newtype SupervisorType = SupervisorType Void 109 | 110 | newtype SupervisorPid = SupervisorPid Pid 111 | 112 | derive newtype instance supervisorPidHasPid :: HasPid SupervisorPid 113 | 114 | type SupervisorRef = RegistryReference SupervisorPid SupervisorType 115 | 116 | type SupervisorInstance = RegistryInstance SupervisorPid SupervisorType 117 | 118 | -- | A complete specification for a supervisor, see `Result` in the underlying supervisor API 119 | type SupervisorSpec = 120 | { flags :: Flags 121 | , childSpecs :: List ErlChildSpec 122 | } 123 | 124 | -- | Given an (optional) name for the supervisor 125 | -- | an effect that will be executed within the context of the new supervisor 126 | -- | execute that effect to get the specification and start a supervisor with that specification 127 | foreign import startLink 128 | :: Maybe (RegistryName SupervisorType) 129 | -> Effect SupervisorSpec 130 | -> Effect (StartLinkResult SupervisorPid) 131 | 132 | -- | A convenience mechanism to stop a supervisor using sys:terminate 133 | data StopTimeoutStrategy 134 | = StopInfinity 135 | | StopTimeout Milliseconds 136 | 137 | foreign import stopFFI :: StopTimeoutStrategy -> SupervisorInstance -> Effect Unit 138 | 139 | stop :: StopTimeoutStrategy -> SupervisorRef -> Effect Unit 140 | stop timeout = registryInstance >>> stopFFI timeout 141 | 142 | foreign import data ErlChildSpec :: Type 143 | 144 | foreign import specFFI 145 | :: forall childProcess 146 | . ChildSpec childProcess 147 | -> ErlChildSpec 148 | 149 | spec 150 | :: forall childProcess 151 | . HasPid childProcess 152 | => ChildSpec childProcess 153 | -> ErlChildSpec 154 | spec = specFFI 155 | 156 | foreign import startChildFFI 157 | :: forall childProcess 158 | . SupervisorInstance 159 | -> ChildSpec childProcess 160 | -> StartChildResult childProcess 161 | 162 | -- | Given a supervisor reference and a child specification 163 | -- | start a new child within the context of that supervisor 164 | -- | See also supervisor:start_child 165 | startChild 166 | :: forall childProcess 167 | . HasPid childProcess 168 | => SupervisorRef 169 | -> ChildSpec childProcess 170 | -> StartChildResult childProcess 171 | startChild r = startChildFFI $ registryInstance r 172 | 173 | foreign import terminateChildFFI :: SupervisorInstance -> String -> Effect TerminateChildResult 174 | foreign import deleteChildFFI :: SupervisorInstance -> String -> Effect DeleteChildResult 175 | 176 | -- | Given a supervisor reference and a child id 177 | -- | terminate that given child 178 | -- | See also supervisor:terminate_child 179 | terminateChild :: SupervisorRef -> String -> Effect TerminateChildResult 180 | terminateChild r id = terminateChildFFI (registryInstance r) id 181 | 182 | -- | Given a supervisor reference and a child id 183 | -- | delete that given child 184 | -- | See also supervisor:delete_child 185 | deleteChild :: SupervisorRef -> String -> Effect DeleteChildResult 186 | deleteChild r id = deleteChildFFI (registryInstance r) id 187 | 188 | -- | Converts a StartChildResult into a Maybe 189 | -- | returning Just if the child was started 190 | -- | and Nothing otherwise 191 | maybeChildStarted :: forall childProcess. StartChildResult childProcess -> Maybe childProcess 192 | maybeChildStarted slr = case slr of 193 | ChildStarted { pid: childProcess } -> Just childProcess 194 | _ -> Nothing 195 | 196 | -- | Converts a StartChildResult into a Maybe 197 | -- | returning Just if the child was started 198 | -- | and Just if the child was already running 199 | -- | and Nothing otherwise 200 | maybeChildRunning :: forall childProcess. StartChildResult childProcess -> Maybe childProcess 201 | maybeChildRunning slr = case slr of 202 | ChildStarted { pid: childProcess } -> Just childProcess 203 | (ChildAlreadyStarted childProcess) -> Just childProcess 204 | _ -> Nothing 205 | 206 | crashIfChildNotStarted :: forall childProcess. StartChildResult childProcess -> childProcess 207 | crashIfChildNotStarted = 208 | unsafePartial \slr -> case maybeChildStarted slr of 209 | Just childProcess -> childProcess 210 | 211 | crashIfChildNotRunning :: forall childProcess. StartChildResult childProcess -> childProcess 212 | crashIfChildNotRunning = 213 | unsafePartial \slr -> case maybeChildRunning slr of 214 | Just childProcess -> childProcess 215 | -------------------------------------------------------------------------------- /src/Pinto/Supervisor/SimpleOneForOne.erl: -------------------------------------------------------------------------------- 1 | -module(pinto_supervisor_simpleOneForOne@foreign). 2 | 3 | %%------------------------------------------------------------------------------ 4 | %% FFI API 5 | %%------------------------------------------------------------------------------ 6 | -export([ startLinkFFI/2 7 | , startChildFFI/2 8 | , terminateChildFFI/2 9 | , deleteChildFFI/2 10 | ]). 11 | 12 | 13 | %%------------------------------------------------------------------------------ 14 | %% Runtime supervisor stubs 15 | %%------------------------------------------------------------------------------ 16 | -export([ start_proxy/2 17 | , init/1 18 | ]). 19 | -purs_ignore_exports([start_proxy/2, init/1]). 20 | 21 | -import('pinto_types@foreign', 22 | [ start_link_result_to_ps/1 23 | , start_link_result_from_ps/1 24 | ]). 25 | 26 | -import('pinto_supervisor@foreign', 27 | [ restart_from_ps/1, 28 | shutdown_from_ps/1, 29 | type_from_ps/1 30 | ]). 31 | init(EffectSupervisorSpec) -> 32 | DynamicSpecPS = EffectSupervisorSpec(), 33 | DynamicSpec = dynamic_spec_from_ps(DynamicSpecPS), 34 | 35 | {ok, DynamicSpec}. 36 | 37 | 38 | %%------------------------------------------------------------------------------ 39 | %% FFI API 40 | %%------------------------------------------------------------------------------ 41 | startLinkFFI(Name, DynamicSpecEffect) -> 42 | fun() -> 43 | startLinkPure(Name, DynamicSpecEffect) 44 | end. 45 | 46 | startLinkPure({nothing}, DynamicSpecEffect) -> 47 | Result = supervisor:start_link(?MODULE, DynamicSpecEffect), 48 | start_link_result_to_ps(Result); 49 | startLinkPure({just, RegistryName}, DynamicSpecEffect) -> 50 | Result = supervisor:start_link(RegistryName, ?MODULE, DynamicSpecEffect), 51 | start_link_result_to_ps(Result). 52 | 53 | startChildFFI(Ref, ChildArg) -> 54 | fun() -> 55 | Result = supervisor:start_child(Ref, [ChildArg]), 56 | start_child_result_to_ps(Result) 57 | end. 58 | 59 | terminateChildFFI(Ref, Id) -> 60 | fun() -> 61 | Result = supervisor:terminate_child(Ref, Id), 62 | terminate_child_result_to_ps(Result) 63 | end. 64 | 65 | deleteChildFFI(Ref, Id) -> 66 | fun() -> 67 | Result = supervisor:delete_child(Ref, Id), 68 | delete_child_result_to_ps(Result) 69 | end. 70 | 71 | %%------------------------------------------------------------------------------ 72 | %% erlang -> ps conversion helpers 73 | %%------------------------------------------------------------------------------ 74 | start_child_result_to_ps({ok, undefined}) -> {childStartReturnedIgnore}; 75 | start_child_result_to_ps({ok, {Pid, Info}}) -> {childStarted, #{pid => Pid, info => {just, Info}}}; 76 | start_child_result_to_ps({ok, Pid}) -> {childStarted, #{pid => Pid, info => {nothing}}}; 77 | start_child_result_to_ps({error, already_present}) -> {childAlreadyPresent}; 78 | start_child_result_to_ps({error, {already_started, Pid}}) -> {childAlreadyStarted, Pid}; 79 | start_child_result_to_ps({error, Other}) -> {childFailed, Other}. 80 | 81 | %% These are deliberately not exhaustive, as this code path will only be hit with simple_one_for_one 82 | delete_child_result_to_ps(ok) -> {childDeleted}; 83 | delete_child_result_to_ps({error, running}) -> {childRunning}; 84 | delete_child_result_to_ps({error, not_found}) -> {childNotFoundToDelete}. 85 | 86 | terminate_child_result_to_ps(ok) -> {childTerminated}; 87 | terminate_child_result_to_ps({error, not_found}) -> {childNotFoundToTerminate}. 88 | 89 | %%------------------------------------------------------------------------------ 90 | %% ps -> erlang conversion helpers 91 | %%------------------------------------------------------------------------------ 92 | dynamic_spec_from_ps(#{ intensity := Intensity 93 | , period := Period 94 | 95 | , start := StartFn 96 | , restartStrategy := RestartStrategy 97 | , shutdownStrategy := ChildShutdownTimeoutStrategy 98 | , childType := ChildType 99 | }) -> 100 | 101 | SupFlags = 102 | #{ strategy => simple_one_for_one 103 | , intensity => Intensity 104 | , period => round(Period) 105 | }, 106 | 107 | ChildSpec = 108 | #{ id => dynamic_child 109 | , start => {?MODULE, start_proxy, [StartFn]} 110 | , restart => restart_from_ps(RestartStrategy) 111 | , shutdown => shutdown_from_ps(ChildShutdownTimeoutStrategy) 112 | , type => type_from_ps(ChildType) 113 | }, 114 | 115 | { SupFlags, [ ChildSpec ] }. 116 | 117 | 118 | 119 | start_proxy(StartFn, StartArg) -> 120 | StartEffect = StartFn(StartArg), 121 | StartResult = StartEffect(), 122 | start_link_result_from_ps(StartResult). 123 | -------------------------------------------------------------------------------- /src/Pinto/Supervisor/SimpleOneForOne.purs: -------------------------------------------------------------------------------- 1 | -- | This module represents a simple_one_for_one supervisor in OTP 2 | -- | It is a special case because if it has different return values and arguments for pretty much every function 3 | -- | See also gen_supervisor in the OTP docs (https://erlang.org/doc/man/supervisor.html#) 4 | module Pinto.Supervisor.SimpleOneForOne 5 | ( ChildSpec 6 | , SupervisorRef(..) 7 | , SupervisorPid 8 | , SupervisorType 9 | , startLink 10 | , startChild 11 | , terminateChild 12 | , deleteChild 13 | ) where 14 | 15 | import Prelude 16 | import Data.Maybe (Maybe) 17 | import Data.Time.Duration (Seconds) 18 | import Effect (Effect) 19 | import Erl.Process.Raw (Pid, class HasPid) 20 | import Pinto.Supervisor (ChildShutdownTimeoutStrategy, ChildType, RestartStrategy, StartChildResult, TerminateChildResult, DeleteChildResult) 21 | import Pinto.Types (RegistryInstance, RegistryName, RegistryReference, StartLinkResult, registryInstance) 22 | 23 | newtype SupervisorType :: Type -> Type -> Type 24 | newtype SupervisorType childStartArg childProcess = SupervisorType Void 25 | 26 | newtype SupervisorPid :: Type -> Type -> Type 27 | newtype SupervisorPid childStartArg childProcess = SupervisorPid Pid 28 | 29 | derive newtype instance supervisorPidHasPid :: HasPid (SupervisorPid childStartArg childProcess) 30 | 31 | type SupervisorRef childStartArg childProcess = RegistryReference (SupervisorPid childStartArg childProcess) (SupervisorType childStartArg childProcess) 32 | 33 | type SupervisorInstance childStartArg childProcess = RegistryInstance (SupervisorPid childStartArg childProcess) (SupervisorType childStartArg childProcess) 34 | 35 | -- | The specification of the dynamic child process, this maps to ChildSpec in the underlying supervisor API 36 | -- | with the difference that none of them are optional 37 | -- | `childStartArg` is the parameter expected by the start function for the child. It is provided here 38 | -- | `childProcess` is the typed pid of the started process (commonly GenServer.ServerPid) 39 | type ChildSpec childStartArg childProcess = 40 | { intensity :: Int 41 | , period :: Seconds 42 | , start :: childStartArg -> Effect (StartLinkResult childProcess) 43 | , restartStrategy :: RestartStrategy 44 | , shutdownStrategy :: ChildShutdownTimeoutStrategy 45 | , childType :: ChildType 46 | } 47 | 48 | -- | Start the supervisor, running the provided Effect to get the spec of the children that this OneForOne supervisor can start 49 | -- | Returns a pid that can be used to communicate with the supervisor in the startChild call 50 | startLink 51 | :: forall childStartArg childProcess 52 | . HasPid childProcess 53 | => Maybe (RegistryName (SupervisorType childStartArg childProcess)) 54 | -> Effect (ChildSpec childStartArg childProcess) 55 | -> Effect (StartLinkResult (SupervisorPid childStartArg childProcess)) 56 | startLink = startLinkFFI 57 | 58 | foreign import startLinkFFI 59 | :: forall childStartArg childProcess 60 | . Maybe (RegistryName (SupervisorType childStartArg childProcess)) 61 | -> Effect (ChildSpec childStartArg childProcess) 62 | -> Effect (StartLinkResult (SupervisorPid childStartArg childProcess)) 63 | 64 | -- | Starts a child within th one_for_one supervisor referred to by `SupervisorRef childStartArg childProcess` 65 | -- | See also supervisor:start_child in the OTP documentation 66 | startChild 67 | :: forall childStartArg childProcess 68 | . HasPid childProcess 69 | => SupervisorRef childStartArg childProcess 70 | -> childStartArg 71 | -> Effect (StartChildResult childProcess) 72 | startChild = startChildFFI <<< registryInstance 73 | 74 | foreign import startChildFFI 75 | :: forall childStartArg childProcess 76 | . SupervisorInstance childStartArg childProcess 77 | -> childStartArg 78 | -> Effect (StartChildResult childProcess) 79 | 80 | foreign import terminateChildFFI :: forall childStartArg childProcess. SupervisorInstance childStartArg childProcess -> childProcess -> Effect TerminateChildResult 81 | foreign import deleteChildFFI :: forall childStartArg childProcess. SupervisorInstance childStartArg childProcess -> childProcess -> Effect DeleteChildResult 82 | 83 | -- | Terminates a child within the one_for_one supervisor referred to by `SupervisorRef childStartArg childProcess` 84 | -- | See also supervisor:terminate_child in the OTP documentation 85 | terminateChild :: forall childStartArg childProcess. SupervisorRef childStartArg childProcess -> childProcess -> Effect TerminateChildResult 86 | terminateChild r p = terminateChildFFI (registryInstance r) p 87 | 88 | -- | Deletes a child within the one_for_one supervisor referred to by `SupervisorRef childStartArg childProcess` 89 | -- | See also supervisor:deleted_child in the OTP documentation 90 | deleteChild :: forall childStartArg childProcess. SupervisorRef childStartArg childProcess -> childProcess -> Effect DeleteChildResult 91 | deleteChild r p = deleteChildFFI (registryInstance r) p 92 | -------------------------------------------------------------------------------- /src/Pinto/Timer.erl: -------------------------------------------------------------------------------- 1 | -module(pinto_timer@foreign). 2 | 3 | -export([ cancel/1, 4 | sendEveryToFFI/3, 5 | sendAfterToFFI/3 ]). 6 | 7 | cancel(WrappedRef) -> 8 | fun() -> 9 | case WrappedRef of 10 | { timer, Ref } -> 11 | timer:cancel(Ref); 12 | { erlang, Ref } -> 13 | erlang:cancel_timer(Ref) 14 | end 15 | end. 16 | 17 | sendEveryToFFI(Milliseconds,Msg, Target) -> 18 | fun() -> 19 | { ok, Ref } = timer:send_interval(round(Milliseconds), Target, Msg), 20 | { timer, Ref } 21 | end. 22 | 23 | sendAfterToFFI(Milliseconds, Msg, Target) -> 24 | fun() -> 25 | Ref = erlang:send_after(round(Milliseconds), Target, Msg), 26 | { erlang, Ref } 27 | end. 28 | -------------------------------------------------------------------------------- /src/Pinto/Timer.purs: -------------------------------------------------------------------------------- 1 | -- | This module provides a means of using the timer functionality in core Erlang 2 | -- | It'll work anywhere, it's up to you to route the messages sensibly once you have them in the callback 3 | -- | Tip: See 'emitter' in Gen 4 | module Pinto.Timer 5 | ( sendEvery 6 | , sendAfter 7 | , sendEveryTo 8 | , sendAfterTo 9 | , cancel 10 | , TimerRef 11 | ) where 12 | 13 | import Prelude 14 | import Effect (Effect) 15 | import Effect.Class (liftEffect, class MonadEffect) 16 | import Data.Time.Duration (Milliseconds) 17 | import Erl.Process (class HasProcess, Process, getProcess, class HasSelf, self) 18 | 19 | foreign import data TimerRef :: Type 20 | 21 | -- | sends a message to 'self' every 'N' milliseconds 22 | -- | See also timer:send_every in the OTP docs 23 | -- | Note: This uses the old Timer API 24 | sendEvery 25 | :: forall m msg 26 | . MonadEffect m 27 | => HasSelf m msg 28 | => Milliseconds 29 | -> msg 30 | -> m TimerRef 31 | sendEvery t m = do 32 | self <- self 33 | liftEffect $ sendEveryToFFI t m self 34 | 35 | -- | sends a message to 'self' after 'N' milliseconds 36 | -- | See also erlang:send_after in the OTP docs 37 | -- | Note: This uses the new Timer API 38 | sendAfter 39 | :: forall m msg 40 | . MonadEffect m 41 | => HasSelf m msg 42 | => Milliseconds 43 | -> msg 44 | -> m TimerRef 45 | sendAfter t m = do 46 | self <- self 47 | liftEffect $ sendAfterToFFI t m self 48 | 49 | -- | Send `msg` to `process` every 'N' milliseconds 50 | -- | See also timer:send_every in the OTP docs 51 | -- | Note: This uses the old Timer API 52 | sendEveryTo :: forall msg process. HasProcess msg process => Milliseconds -> msg -> process -> Effect TimerRef 53 | sendEveryTo t m p = sendEveryToFFI t m $ getProcess p 54 | 55 | -- | Send `msg` to `process` after 'N' milliseconds 56 | -- | See also erlang:send_after in the OTP docs 57 | -- | Note: This uses the new Timer API 58 | sendAfterTo :: forall msg process. HasProcess msg process => Milliseconds -> msg -> process -> Effect TimerRef 59 | sendAfterTo t m p = sendAfterToFFI t m $ getProcess p 60 | 61 | -- | Given a TimerRef, cancels the timer as per timer:cancel/erlang:cancel_timer in the OTP docs 62 | foreign import cancel :: TimerRef -> Effect Unit 63 | 64 | foreign import sendEveryToFFI :: forall msg. Milliseconds -> msg -> Process msg -> Effect TimerRef 65 | foreign import sendAfterToFFI :: forall msg. Milliseconds -> msg -> Process msg -> Effect TimerRef 66 | -------------------------------------------------------------------------------- /src/Pinto/Types.erl: -------------------------------------------------------------------------------- 1 | -module(pinto_types@foreign). 2 | 3 | -include_lib("kernel/include/logger.hrl"). 4 | 5 | -export([ start_link_result_to_ps/1 6 | , start_link_result_from_ps/1 7 | , parseTrappedExitFFI/2 8 | , parseShutdownReasonFFI/1 9 | ]). 10 | 11 | %% imported in other ffi 12 | -purs_ignore_exports([start_link_result_to_ps/1]). 13 | 14 | start_link_result_to_ps({ok, Pid}) -> {right, Pid}; 15 | start_link_result_to_ps(ignore) -> {left, {ignore}}; 16 | start_link_result_to_ps({error, {already_started, Pid}}) -> {left, {alreadyStarted, Pid}}; 17 | start_link_result_to_ps({error, Other}) -> {left, {failed, Other}}. 18 | 19 | start_link_result_from_ps({right, Pid}) -> {ok, Pid}; 20 | start_link_result_from_ps({left, {ignore}}) -> ignore; 21 | start_link_result_from_ps({left, {alreadyStarted, Pid}}) -> {error, {already_started, Pid}}; 22 | start_link_result_from_ps({left, {failed, Other}}) -> {error, Other}. 23 | 24 | parseTrappedExitFFI({ 'EXIT', Pid, Reason }, ExitMsg) -> 25 | {just, (ExitMsg(Pid))(Reason)}; 26 | 27 | parseTrappedExitFFI(_,_) -> 28 | {nothing}. 29 | 30 | parseShutdownReasonFFI(normal) -> 31 | {reasonNormal}; 32 | 33 | parseShutdownReasonFFI(shutdown) -> 34 | {reasonShutdown, {nothing}}; 35 | 36 | parseShutdownReasonFFI({shutdown, Reason}) -> 37 | {reasonShutdown, {just, Reason}}; 38 | 39 | parseShutdownReasonFFI(SomethingElse) -> 40 | {reasonOther, SomethingElse}. 41 | -------------------------------------------------------------------------------- /src/Pinto/Types.purs: -------------------------------------------------------------------------------- 1 | module Pinto.Types 2 | ( TerminateReason(..) 3 | , RegistryName(..) 4 | , StartLinkResult 5 | , NotStartedReason(..) 6 | , maybeStarted 7 | , maybeRunning 8 | , crashIfNotStarted 9 | , crashIfNotRunning 10 | , startLinkResultFromPs 11 | , registryInstance 12 | , RegistryInstance 13 | , RegistryReference(..) 14 | , ExitMessage(..) 15 | , ShutdownReason(..) 16 | , parseShutdownReasonFFI 17 | , parseTrappedExitFFI 18 | , class ExportsTo 19 | , export 20 | ) where 21 | 22 | import Prelude 23 | import Data.Either (Either(..)) 24 | import Data.Maybe (Maybe(..)) 25 | import Erl.Atom (Atom) 26 | import Erl.ModuleName (NativeModuleName) 27 | import Erl.Process.Raw (class HasPid, Pid, getPid) 28 | import Foreign (Foreign) 29 | import Partial.Unsafe (unsafePartial) 30 | import Unsafe.Coerce (unsafeCoerce) 31 | 32 | -- | The name of a registered process, these map to 33 | -- | `{local, Name}` 34 | -- | `{global, GlobalName}` 35 | -- | `{via, Module, ViaName}` 36 | -- | as per the docs for gen_server:start_link and similar 37 | data RegistryName :: Type -> Type 38 | data RegistryName serverType 39 | = Local Atom 40 | | Global Foreign 41 | | Via NativeModuleName Foreign 42 | 43 | -- | A means of looking up a typed process (such as a GenServer) 44 | -- | that may or may not be registered 45 | -- | 46 | -- | This is typically used by the APIs provided to gain access 47 | -- | to the ability to invoke code within the context of a started server 48 | -- | 49 | -- | ```purescript 50 | -- | GenServer.call (ByName serverName) \_from a... 51 | -- | ``` 52 | data RegistryReference :: Type -> Type -> Type 53 | data RegistryReference serverPid serverType 54 | = ByPid serverPid 55 | | ByName (RegistryName serverType) 56 | 57 | foreign import data RegistryInstance :: Type -> Type -> Type 58 | 59 | -- | Given a `RegistryReference serverPid serverType` 60 | -- | 61 | -- | Create a `RegistryInstance serverPid serverType` that can be used 62 | -- | to communicate with that process directly 63 | registryInstance 64 | :: forall serverPid serverType 65 | . HasPid serverPid 66 | => RegistryReference serverPid serverType 67 | -> RegistryInstance serverPid serverType 68 | registryInstance (ByPid pid) = registryPidToInstance pid 69 | 70 | registryInstance (ByName name) = registryNameToInstance name 71 | 72 | registryPidToInstance :: forall serverPid serverType. HasPid serverPid => serverPid -> RegistryInstance serverPid serverType 73 | registryPidToInstance serverPid = unsafeCoerce $ getPid serverPid 74 | 75 | registryNameToInstance :: forall serverPid serverType. RegistryName serverType -> RegistryInstance serverPid serverType 76 | registryNameToInstance (Local atom) = unsafeCoerce atom 77 | 78 | registryNameToInstance other = unsafeCoerce other 79 | 80 | data ExitMessage = Exit Pid Foreign 81 | 82 | data ShutdownReason 83 | = ReasonNormal 84 | | ReasonShutdown (Maybe Foreign) 85 | | ReasonOther Foreign 86 | 87 | foreign import parseTrappedExitFFI :: Foreign -> (Pid -> Foreign -> ExitMessage) -> Maybe ExitMessage 88 | 89 | foreign import parseShutdownReasonFFI :: Foreign -> ShutdownReason 90 | 91 | data NotStartedReason serverProcess 92 | = Ignore 93 | | AlreadyStarted serverProcess 94 | | Failed Foreign 95 | 96 | derive instance Functor NotStartedReason 97 | 98 | instance (Show serverProcess) => Show (NotStartedReason serverProcess) where 99 | show Ignore = "Ignore" 100 | show (AlreadyStarted process) = "(AlreadyStarted " <> show process <> ")" 101 | show (Failed _) = "Failed (foreign)" 102 | 103 | type StartLinkResult serverProcess = Either (NotStartedReason serverProcess) serverProcess 104 | 105 | data TerminateReason 106 | = Normal 107 | | Shutdown 108 | | ShutdownWithCustom Foreign 109 | | Custom Foreign 110 | 111 | maybeStarted :: forall serverProcess. StartLinkResult serverProcess -> Maybe serverProcess 112 | maybeStarted slr = case slr of 113 | Right serverProcess -> Just serverProcess 114 | _ -> Nothing 115 | 116 | maybeRunning :: forall serverProcess. StartLinkResult serverProcess -> Maybe serverProcess 117 | maybeRunning slr = case slr of 118 | Right serverProcess -> Just serverProcess 119 | Left (AlreadyStarted serverProcess) -> Just serverProcess 120 | _ -> Nothing 121 | 122 | crashIfNotStarted :: forall serverProcess. StartLinkResult serverProcess -> serverProcess 123 | crashIfNotStarted = 124 | unsafePartial \slr -> case maybeStarted slr of 125 | Just serverProcess -> serverProcess 126 | 127 | crashIfNotRunning :: forall serverProcess. StartLinkResult serverProcess -> serverProcess 128 | crashIfNotRunning = 129 | unsafePartial \slr -> case maybeRunning slr of 130 | Just serverProcess -> serverProcess 131 | 132 | startLinkResultFromPs :: forall a. StartLinkResult a -> Foreign 133 | startLinkResultFromPs = start_link_result_from_ps 134 | 135 | foreign import start_link_result_from_ps :: forall a. StartLinkResult a -> Foreign 136 | 137 | class ExportsTo a b where 138 | export :: a -> b 139 | -------------------------------------------------------------------------------- /test.dhall: -------------------------------------------------------------------------------- 1 | let base = ./spago.dhall 2 | 3 | in base 4 | ⫽ { sources = 5 | base.sources # [ "test/**/*.purs" ] 6 | , dependencies = 7 | base.dependencies # [ "assert", "erl-test-eunit", "free", "console" ] 8 | } 9 | -------------------------------------------------------------------------------- /test/.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((purescript-mode 5 | (psc-ide-codegen "corefn") 6 | )) 7 | -------------------------------------------------------------------------------- /test/DoorLock.purs: -------------------------------------------------------------------------------- 1 | module Test.DoorLock 2 | ( testSuite 3 | , startLink 4 | , State 5 | , StateId 6 | , TimerContent 7 | , DoorLockPid 8 | ) where 9 | 10 | import Prelude 11 | import Control.Monad.Free (Free) 12 | import Data.Maybe (Maybe(..)) 13 | import Effect (Effect) 14 | import Erl.Atom (atom) 15 | import Erl.Process.Raw (class HasPid) 16 | import Erl.Test.EUnit (TestF, suite, test) 17 | import Pinto.GenStatem (class HasStateId, Event(..), InitResult(..), StatemPid, StatemType, Timeout(..), TimeoutAction(..), EventResult(..), StateEnterResult(..), StatemRef(..)) 18 | import Pinto.GenStatem as Statem 19 | import Pinto.Types (RegistryName(..), RegistryReference(..), crashIfNotStarted) 20 | import Test.Assert (assertEqual) 21 | 22 | -- ----------------------------------------------------------------------------- 23 | -- Test Implementation 24 | -- ----------------------------------------------------------------------------- 25 | testSuite :: Free TestF Unit 26 | testSuite = 27 | suite "Pinto 'DoorLock' GenStatem Tests" do 28 | test "Can create a DoorLock and interact with it" do 29 | serverPid <- startLink 30 | failedOpenResultLocked <- open 31 | assertEqual { actual: failedOpenResultLocked, expected: OpenFailedInvalidState } 32 | failedUnlockResult <- unlock "NOT_THE_CODE" 33 | assertEqual { actual: failedUnlockResult, expected: InvalidCode } 34 | successUnlockResult <- unlock "THE_CODE" 35 | assertEqual { actual: successUnlockResult, expected: UnlockSuccess } 36 | invalidStateUnlockResult <- unlock "NO_LONGER_MATTERS" 37 | assertEqual { actual: invalidStateUnlockResult, expected: InvalidState } 38 | successOpenResult <- open 39 | assertEqual { actual: successOpenResult, expected: OpenSuccess } 40 | failedOpenResultAlreadyOpen <- open 41 | assertEqual { actual: failedOpenResultAlreadyOpen, expected: OpenFailedInvalidState } 42 | -- to test 43 | -- - cast 44 | -- - timeout (door open too long) 45 | -- - info messages 46 | -- - internal messages 47 | -- - regular timeout messages 48 | -- - at timeouts? 49 | -- - timeout cancelation 50 | -- - stop 51 | -- - ignore 52 | -- to implement 53 | -- - named timeouts 54 | -- - postpone (incl not_implemented) 55 | -- - next event 56 | -- - hibernate 57 | -- let 58 | -- instanceRef = ByPid serverPid 59 | -- state1 <- getState instanceRef 60 | -- state2 <- setState instanceRef (TestState 1) 61 | -- state3 <- getState instanceRef 62 | -- setStateCast instanceRef (TestState 2) 63 | -- state4 <- getState instanceRef 64 | -- assertEqual { actual: state1, expected: TestState 0 } 65 | -- assertEqual { actual: state2, expected: TestState 0 } 66 | -- assertEqual { actual: state3, expected: TestState 1 } 67 | -- assertEqual { actual: state4, expected: TestState 2 } 68 | pure unit 69 | 70 | -- ----------------------------------------------------------------------------- 71 | -- Statem Implementation 72 | -- ----------------------------------------------------------------------------- 73 | data StateId 74 | = StateIdLocked 75 | | StateIdUnlockedClosed 76 | | StateIdUnlockedOpen 77 | 78 | derive instance eqStateId :: Eq StateId 79 | 80 | data State 81 | = Locked { failedAttempts :: Int } 82 | | UnlockedClosed { failedAttemptsBeforeUnlock :: Int } 83 | | UnlockedOpen { failedAttemptsBeforeUnlock :: Int } 84 | 85 | instance stateHasStateId :: HasStateId StateId State where 86 | getStateId (Locked _) = StateIdLocked 87 | getStateId (UnlockedClosed _) = StateIdUnlockedClosed 88 | getStateId (UnlockedOpen _) = StateIdUnlockedOpen 89 | 90 | type Data = 91 | { code :: String 92 | , unknownEvents :: Int 93 | } 94 | 95 | type Info = Void 96 | 97 | type Internal = Void 98 | 99 | type TimerName = Void 100 | 101 | data TimerContent = DoorOpenTooLong 102 | 103 | type DoorLockType = StatemType Info Internal TimerName TimerContent Data StateId State 104 | 105 | newtype DoorLockPid = DoorLockPid (StatemPid Info Internal TimerName TimerContent Data StateId State) 106 | 107 | -- Only surface the raw pid, don't implement HasProcess - we don't want folks sending us messages using our Info 108 | -- type 109 | derive newtype instance doorLockPidHasPid :: HasPid DoorLockPid 110 | 111 | data AuditEvent 112 | = AuditDoorUnlocked 113 | | AuditDoorOpened 114 | | AuditDoorClosed 115 | | AuditDoorLocked 116 | | AuditDoorOpenTooLong 117 | | AuditUnexpectedEventInState 118 | 119 | name :: RegistryName DoorLockType 120 | name = Local $ atom "doorLock" 121 | 122 | startLink :: Effect DoorLockPid 123 | startLink = do 124 | DoorLockPid <$> crashIfNotStarted <$> (Statem.startLink $ ((Statem.defaultSpec init handleEvent) { name = Just name, handleEnter = Just handleEnter })) 125 | where 126 | init = 127 | let 128 | initialState = Locked { failedAttempts: 0 } 129 | 130 | initialData = 131 | { code: "THE_CODE" 132 | , unknownEvents: 0 133 | } 134 | in 135 | do 136 | _ <- Statem.self 137 | pure $ InitOk initialState initialData 138 | 139 | handleEnter StateIdLocked StateIdUnlockedClosed _state _commonData = do 140 | _ <- Statem.self 141 | audit AuditDoorUnlocked # Statem.lift 142 | pure $ StateEnterKeepData 143 | 144 | handleEnter StateIdUnlockedOpen StateIdUnlockedClosed _state _commonData = do 145 | audit AuditDoorClosed # Statem.lift 146 | pure $ StateEnterKeepData 147 | 148 | handleEnter _previousStateId StateIdUnlockedOpen _state _commonData = do 149 | audit AuditDoorOpened # Statem.lift 150 | let 151 | actions = Statem.newActions # auditIfOpenTooLong 152 | pure $ StateEnterKeepDataWithActions actions 153 | 154 | handleEnter _previousStateId StateIdLocked _state _commonData = do 155 | audit AuditDoorLocked # Statem.lift 156 | pure $ StateEnterKeepData 157 | 158 | handleEnter _previousStateId _currentStateId _state _commonData = do 159 | pure $ StateEnterKeepData 160 | 161 | handleEvent (EventStateTimeout DoorOpenTooLong) _state _commonData = do 162 | audit AuditDoorOpenTooLong # Statem.lift 163 | pure $ EventKeepStateAndData 164 | 165 | handleEvent event state commonData@{ unknownEvents } = do 166 | -- TODO: log bad event 167 | _ <- Statem.self 168 | audit AuditUnexpectedEventInState # Statem.lift 169 | pure $ EventKeepState (commonData { unknownEvents = unknownEvents + 1 }) 170 | 171 | auditIfOpenTooLong actions = do 172 | Statem.addTimeoutAction (SetStateTimeout (After 0 DoorOpenTooLong)) actions 173 | 174 | audit :: AuditEvent -> Effect Unit 175 | audit event = do 176 | pure unit 177 | 178 | -- ----------------------------------------------------------------------------- 179 | -- Door Unlock 180 | -- ----------------------------------------------------------------------------- 181 | data UnlockResult 182 | = UnlockSuccess 183 | | InvalidCode 184 | | InvalidState 185 | 186 | derive instance eqUnlockResult :: Eq UnlockResult 187 | 188 | instance showUnlockResult :: Show UnlockResult where 189 | show UnlockSuccess = "Success" 190 | show InvalidCode = "Invalid Code" 191 | show InvalidState = "Invalid State" 192 | 193 | unlock :: String -> Effect UnlockResult 194 | unlock code = Statem.call (ByName name) impl 195 | where 196 | impl from (Locked stateData) commonData@{ code: actualCode } = 197 | if actualCode == code then do 198 | let 199 | actions = Statem.newActions # Statem.addReply (Statem.reply from UnlockSuccess) 200 | pure $ EventNextStateWithActions (UnlockedClosed { failedAttemptsBeforeUnlock: stateData.failedAttempts }) commonData actions 201 | else do 202 | let 203 | actions = Statem.newActions # Statem.addReply (Statem.reply from InvalidCode) 204 | pure $ EventNextStateWithActions (Locked (stateData { failedAttempts = stateData.failedAttempts + 1 })) commonData actions 205 | 206 | impl from _invalidState _commonData = do 207 | let 208 | actions = Statem.newActions # Statem.addReply (Statem.reply from InvalidState) 209 | pure $ EventKeepStateAndDataWithActions actions 210 | 211 | -- ----------------------------------------------------------------------------- 212 | -- Door Open 213 | -- ----------------------------------------------------------------------------- 214 | data OpenResult 215 | = OpenSuccess 216 | | OpenFailedInvalidState 217 | 218 | derive instance eqOpenResult :: Eq OpenResult 219 | 220 | instance showOpenResult :: Show OpenResult where 221 | show OpenSuccess = "Success" 222 | show OpenFailedInvalidState = "Invalid State" 223 | 224 | open :: Effect OpenResult 225 | open = Statem.call (ByName name) impl 226 | where 227 | impl from (UnlockedClosed { failedAttemptsBeforeUnlock }) commonData = 228 | let 229 | actions = Statem.newActions # Statem.addReply (Statem.reply from OpenSuccess) 230 | in 231 | pure $ EventNextStateWithActions (UnlockedOpen { failedAttemptsBeforeUnlock }) commonData actions 232 | 233 | impl from _invalidState _commonData = 234 | let 235 | actions = Statem.newActions # Statem.addReply (Statem.reply from OpenFailedInvalidState) 236 | in 237 | pure $ EventKeepStateAndDataWithActions actions 238 | -------------------------------------------------------------------------------- /test/GenServer.erl: -------------------------------------------------------------------------------- 1 | -module(test_genServer@foreign). 2 | 3 | -export([ sleep/1 4 | ]). 5 | 6 | sleep(Ms) -> 7 | fun() -> 8 | timer:sleep(Ms), 9 | unit 10 | end. 11 | -------------------------------------------------------------------------------- /test/GenServer.purs: -------------------------------------------------------------------------------- 1 | module Test.GenServer 2 | ( genServerSuite 3 | ) where 4 | 5 | import Prelude 6 | import Control.Monad.Free (Free) 7 | import Data.Either (Either(..)) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Time.Duration (Milliseconds(..)) 10 | import Effect (Effect) 11 | import Effect.Class (liftEffect) 12 | import Erl.Atom (atom) 13 | import Erl.Process (Process, (!)) 14 | import Erl.Process.Raw (Pid) 15 | import Erl.Process.Raw as Raw 16 | import Erl.Test.EUnit (TestF, suite, test) 17 | import Foreign (unsafeToForeign) 18 | import Partial.Unsafe (unsafeCrashWith) 19 | import Pinto.GenServer (Action(..), ExitMessage, From, InitResult(..), ServerRef, ServerSpec, ServerType) 20 | import Pinto.GenServer as GS 21 | import Pinto.Types (NotStartedReason(..), RegistryName(..), RegistryReference(..), StartLinkResult, crashIfNotStarted) 22 | import Test.Assert (assert', assertEqual) 23 | import Test.ValueServer as ValueServer 24 | import Unsafe.Coerce (unsafeCoerce) 25 | 26 | foreign import sleep :: Int -> Effect Unit 27 | 28 | type TestServerType = ServerType TestCont TestStop TestMsg TestState 29 | 30 | genServerSuite :: Free TestF Unit 31 | genServerSuite = 32 | suite "Pinto genServer tests" do 33 | testStartLinkAnonymous 34 | testStartLinkLocal 35 | testStartLinkGlobal 36 | testStopNormalLocal 37 | testStopNormalGlobal 38 | testHandleInfo 39 | testCall 40 | testCast 41 | testValueServer 42 | testTrapExits 43 | 44 | data TestState = TestState Int 45 | 46 | derive instance eqTestState :: Eq TestState 47 | 48 | instance showTestState :: Show TestState where 49 | show (TestState x) = "TestState: " <> show x 50 | 51 | data TestCont 52 | = TestCont 53 | | TestContFrom (From TestState) 54 | 55 | data TestMsg 56 | = TestMsg 57 | | TrappedExit ExitMessage 58 | 59 | data TestStop = StopReason 60 | 61 | testStartLinkAnonymous :: Free TestF Unit 62 | testStartLinkAnonymous = 63 | test "Can start an anonymous GenServer" do 64 | serverPid <- crashIfNotStarted <$> (GS.startLink $ (GS.defaultSpec init)) 65 | let 66 | instanceRef = ByPid serverPid 67 | state1 <- getState instanceRef 68 | state2 <- setState instanceRef (TestState 1) 69 | state3 <- getState instanceRef 70 | setStateCast instanceRef (TestState 2) 71 | state4 <- getState instanceRef 72 | assertEqual { actual: state1, expected: TestState 0 } 73 | assertEqual { actual: state2, expected: TestState 0 } 74 | assertEqual { actual: state3, expected: TestState 1 } 75 | assertEqual { actual: state4, expected: TestState 2 } 76 | pure unit 77 | where 78 | init = do 79 | pure $ InitOk (TestState 0) 80 | 81 | testStartLinkLocal :: Free TestF Unit 82 | testStartLinkLocal = 83 | test "Can start a locally named GenServer" do 84 | testStartGetSet $ Local $ atom "testStartLinkLocal" 85 | 86 | testStartLinkGlobal :: Free TestF Unit 87 | testStartLinkGlobal = 88 | test "Can start a globally named GenServer" do 89 | testStartGetSet $ Global (unsafeToForeign $ atom "testStartLinkGlobal") 90 | 91 | testStopNormalLocal :: Free TestF Unit 92 | testStopNormalLocal = 93 | test "Can start and stop a locally named GenServer" do 94 | testStopNormal $ Local $ atom "testStopNormalLocal" 95 | 96 | testStopNormalGlobal :: Free TestF Unit 97 | testStopNormalGlobal = 98 | test "Can start and stop a globally named GenServer" do 99 | testStopNormal $ Global (unsafeToForeign $ atom "testStopNormalGlobal") 100 | 101 | testHandleInfo :: Free TestF Unit 102 | testHandleInfo = 103 | test "HandleInfo handler receives message" do 104 | serverPid <- crashIfNotStarted <$> (GS.startLink $ (GS.defaultSpec init) { handleInfo = Just handleInfo }) 105 | (unsafeCoerce serverPid :: Process TestMsg) ! TestMsg 106 | state <- getState (ByPid serverPid) 107 | assertEqual 108 | { actual: state 109 | , expected: TestState 1 110 | } 111 | pure unit 112 | where 113 | init = do 114 | pure $ InitOk $ TestState 0 115 | 116 | handleInfo _ (TestState x) = do 117 | pure $ GS.return $ TestState $ x + 1 118 | 119 | testCall :: Free TestF Unit 120 | testCall = 121 | test "Can create gen_server:call handlers" do 122 | serverPid <- crashIfNotStarted <$> (GS.startLink $ GS.defaultSpec init) 123 | state <- getState (ByPid serverPid) 124 | assertEqual 125 | { actual: state 126 | , expected: TestState 7 127 | } 128 | pure unit 129 | where 130 | init = do 131 | pure $ InitOk $ TestState 7 132 | 133 | testCast :: Free TestF Unit 134 | testCast = 135 | test "HandleCast changes state" do 136 | serverPid <- crashIfNotStarted <$> (GS.startLink $ (GS.defaultSpec init)) 137 | setStateCast (ByPid serverPid) $ TestState 42 138 | state <- getState (ByPid serverPid) 139 | assertEqual 140 | { actual: state 141 | , expected: TestState 42 142 | } 143 | pure unit 144 | where 145 | init = do 146 | pure $ InitOk $ TestState 0 147 | 148 | testValueServer :: Free TestF Unit 149 | testValueServer = 150 | test "Interaction with gen_server with closed API" do 151 | void $ ValueServer.startLink 152 | void $ ValueServer.setValue 42 153 | v1 <- ValueServer.setValue 43 154 | v2 <- ValueServer.getValue 155 | ValueServer.setValueAsync 50 156 | v3 <- ValueServer.getValue 157 | ValueServer.stop 158 | assertEqual { actual: v1, expected: 42 } 159 | assertEqual { actual: v2, expected: 43 } 160 | assertEqual { actual: v3, expected: 50 } 161 | pure unit 162 | 163 | type TrapExitState = 164 | { testPid :: Pid 165 | , receivedExit :: Boolean 166 | , receivedTerminate :: Boolean 167 | } 168 | 169 | testTrapExits :: Free TestF Unit 170 | testTrapExits = 171 | suite "Trapped exits" do 172 | test "Children's exits get translated when requested" do 173 | serverPid <- crashIfNotStarted <$> (GS.startLink $ (GS.defaultSpec init) { handleInfo = Just handleInfo, trapExits = Just TrappedExit }) 174 | state <- getState (ByPid serverPid) 175 | assertEqual 176 | { actual: state.receivedExit 177 | , expected: true 178 | } 179 | pure unit 180 | test "Parent exits arrive in the terminate callback" do 181 | testPid <- Raw.self 182 | void $ Raw.spawnLink $ void $ crashIfNotStarted <$> (GS.startLink $ (GS.defaultSpec $ init2 testPid) { terminate = Just terminate, trapExits = Just TrappedExit }) 183 | receivedTerminate <- Raw.receiveWithTimeout (Milliseconds 500.0) false 184 | assert' "Terminate wasn't called on the genserver" receivedTerminate 185 | where 186 | init = do 187 | pid <- liftEffect $ Raw.spawnLink $ Raw.receiveWithTimeout (Milliseconds 0.0) unit 188 | pure $ InitOk $ { testPid: pid, receivedExit: false, receivedTerminate: false } 189 | 190 | init2 pid = do 191 | pure $ InitOk $ { testPid: pid, receivedExit: false, receivedTerminate: false } 192 | 193 | handleInfo (TrappedExit exit) s = do 194 | pure $ GS.return $ s { receivedExit = true } 195 | 196 | handleInfo _ _s = do 197 | unsafeCrashWith "Unexpected message" 198 | 199 | terminate _reason s = do 200 | liftEffect $ Raw.send s.testPid true 201 | 202 | --------------------------------------------------------------------------------- 203 | -- Internal 204 | --------------------------------------------------------------------------------- 205 | testStartGetSet :: RegistryName TestServerType -> Effect Unit 206 | testStartGetSet registryName = do 207 | let 208 | gsSpec :: ServerSpec TestCont TestStop TestMsg TestState 209 | gsSpec = 210 | (GS.defaultSpec init) 211 | { name = Just registryName 212 | , handleInfo = Just handleInfo 213 | , handleContinue = Just handleContinue 214 | } 215 | 216 | instanceRef = ByName registryName 217 | serverPid <- crashIfNotStarted <$> (GS.startLink gsSpec) 218 | maybeServerPid <- GS.whereIs registryName 219 | assert' "The pid that is looked up should be that returned by start" $ maybeServerPid == Just serverPid 220 | getState instanceRef >>= expectState 0 -- Starts with initial state 0 221 | setState instanceRef (TestState 1) >>= expectState 0 -- Set new as 1, old is 0 222 | getState instanceRef >>= expectState 1 -- Previsouly set state returned 223 | setStateCast instanceRef (TestState 2) -- Set new state async 224 | getState instanceRef >>= expectState 2 -- Previsouly set state returned 225 | (unsafeCoerce serverPid :: Process TestMsg) ! TestMsg -- Trigger HandleInfo to add 100 226 | getState instanceRef >>= expectState 102 -- Previsouly set state returned 227 | callContinueReply instanceRef >>= expectState 102 -- Trigger a continue - returning old state 228 | getState instanceRef >>= expectState 202 -- The continue fires updating state befor the next get 229 | callContinueNoReply instanceRef >>= expectState 202 -- Tigger a continue that replies in the continuation 230 | getState instanceRef >>= expectState 302 -- Post the reply, the continuation updates the state 231 | castContinue instanceRef -- Continues are triggered by casts as well 232 | getState instanceRef >>= expectState 402 -- As evidenced by the updated state 233 | stop instanceRef 234 | pure unit 235 | where 236 | init = do 237 | pure $ InitOk (TestState 0) 238 | 239 | handleInfo TestMsg (TestState x) = do 240 | pure $ GS.return $ TestState $ x + 100 241 | 242 | handleInfo _ _s = do 243 | unsafeCrashWith "Unexpected message" 244 | 245 | handleContinue cont (TestState x) = 246 | case cont of 247 | TestCont -> pure $ GS.return $ TestState $ x + 100 248 | TestContFrom from -> do 249 | GS.replyTo from (TestState x) 250 | pure $ GS.return $ TestState $ x + 100 251 | 252 | callContinueReply handle = GS.call handle \_from state -> pure $ GS.replyWithAction state (Continue TestCont) state 253 | 254 | callContinueNoReply handle = GS.call handle \from state -> pure $ GS.noReplyWithAction (Continue $ TestContFrom from) state 255 | 256 | castContinue handle = GS.cast handle \state -> pure $ GS.returnWithAction (Continue TestCont) state 257 | 258 | stop = GS.stop 259 | 260 | testStopNormal :: RegistryName TestServerType -> Effect Unit 261 | testStopNormal registryName = do 262 | let 263 | gsSpec :: ServerSpec TestCont TestStop TestMsg TestState 264 | gsSpec = 265 | (GS.defaultSpec init) 266 | { name = Just registryName 267 | , handleInfo = Just handleInfo 268 | , handleContinue = Just handleContinue 269 | } 270 | 271 | instanceRef = ByName registryName 272 | void $ crashIfNotStarted <$> (GS.startLink gsSpec) 273 | getState instanceRef >>= expectState 0 -- Starts with initial state 0 274 | -- Try to start the server again - should fail with already running 275 | (GS.startLink gsSpec) <#> isAlreadyRunning >>= expect true 276 | triggerStopCast instanceRef 277 | sleep 1 -- allow the async cast to execute -- TODO maybe use a monitor with timeout 278 | void $ crashIfNotStarted <$> (GS.startLink gsSpec) 279 | (GS.startLink gsSpec) <#> isAlreadyRunning >>= expect true 280 | triggerStopCallReply instanceRef >>= expectState 42 -- New instance starts with initial state 0 281 | void $ crashIfNotStarted <$> (GS.startLink gsSpec) 282 | getState instanceRef >>= expectState 0 -- New instance starts with initial state 0 283 | -- TODO trigger stop from a handle_info 284 | triggerStopCast instanceRef 285 | pure unit 286 | where 287 | init = do 288 | pure $ InitOk (TestState 0) 289 | 290 | handleInfo TestMsg (TestState x) = do 291 | pure $ GS.return $ TestState $ x + 100 292 | 293 | handleInfo _ _s = do 294 | unsafeCrashWith "Unexpected message" 295 | 296 | handleContinue :: GS.ContinueFn _ _ _ _ 297 | handleContinue cont (TestState x) = 298 | case cont of 299 | TestCont -> pure $ GS.return $ TestState $ x + 100 300 | TestContFrom from -> do 301 | GS.replyTo from (TestState x) 302 | pure $ GS.return $ TestState $ x + 100 303 | 304 | triggerStopCast handle = GS.cast handle \state -> pure $ GS.returnWithAction StopNormal state 305 | 306 | triggerStopCallReply handle = GS.call handle \_from state -> pure $ GS.replyWithAction (TestState 42) StopNormal state 307 | 308 | isAlreadyRunning :: forall serverType. StartLinkResult serverType -> Boolean 309 | isAlreadyRunning = case _ of 310 | Left (AlreadyStarted _) -> true 311 | _ -> false 312 | 313 | expectState :: Int -> TestState -> Effect Unit 314 | expectState expected actual = assertEqual { actual, expected: TestState expected } 315 | 316 | expect :: forall a. Eq a => Show a => a -> a -> Effect Unit 317 | expect expected actual = assertEqual { actual, expected: expected } 318 | 319 | getState :: forall cont stop msg state. ServerRef cont stop msg state -> Effect state 320 | getState handle = 321 | GS.call handle \_from state -> 322 | let 323 | reply = state 324 | in 325 | pure $ GS.reply reply state 326 | 327 | setState :: forall cont stop msg state. ServerRef cont stop msg state -> state -> Effect state 328 | setState handle newState = 329 | GS.call handle \_from state -> 330 | let 331 | reply = state 332 | in 333 | pure $ GS.reply reply newState 334 | 335 | setStateCast :: forall cont stop msg state. ServerRef cont stop msg state -> state -> Effect Unit 336 | setStateCast handle newState = GS.cast handle \_state -> pure $ GS.return newState 337 | -------------------------------------------------------------------------------- /test/GenServer/ContStop.purs: -------------------------------------------------------------------------------- 1 | module Test.GenServer.ContStop 2 | ( genServer2Suite 3 | ) where 4 | 5 | import Prelude 6 | 7 | import Control.Monad.Free (Free) 8 | import Data.Either (Either(..)) 9 | import Data.Maybe (Maybe(..)) 10 | import Effect (Effect) 11 | import Effect.Class (liftEffect) 12 | import Erl.Atom (atom) 13 | import Erl.Process (Process, getProcess, self, send, toPid, (!)) 14 | import Erl.Process as Process 15 | import Erl.Test.EUnit (TestF, suite, test) 16 | import Foreign (unsafeToForeign) 17 | import Partial.Unsafe (unsafeCrashWith) 18 | import Pinto.GenServer.ContStop (Action(..), InitResult(..), ContinueFn) 19 | import Pinto.GenServer.ContStop as GS2 20 | import Erl.ProcessT (ProcessM, ProcessTM, receive) 21 | import Erl.ProcessT.MonitorT (MonitorT, monitor, spawnLinkMonitor) 22 | import Erl.ProcessT.TrapExitT (TrapExitT) 23 | import Pinto.Types (NotStartedReason(..), RegistryName(..), RegistryReference(..), StartLinkResult, crashIfNotStarted) 24 | import Test.Assert (assert', assertEqual) 25 | import Test.TestHelpers (getState, mpTest, setState, setStateCast, sleep) 26 | 27 | type TestServerType = GS2.ServerType TestCont TestStop TestState (ProcessM TestMsg) 28 | 29 | genServer2Suite :: Free TestF Unit 30 | genServer2Suite = 31 | suite "Pinto genServer tests" do 32 | testStartLinkLocal 33 | testStartLinkGlobal 34 | testStopNormalLocal 35 | testStopNormalGlobal 36 | testMonadStatePassedAround 37 | 38 | data TestState = TestState Int 39 | 40 | derive instance eqTestState :: Eq TestState 41 | 42 | instance showTestState :: Show TestState where 43 | show (TestState x) = "TestState: " <> show x 44 | 45 | type TestState2 = 46 | { total :: Int 47 | , parentPid :: Process Int 48 | } 49 | 50 | data TestCont 51 | = TestCont 52 | | TestContFrom (GS2.From TestState) 53 | 54 | data TestMsg 55 | = TestMsg 56 | | TestMsgNotSent 57 | 58 | data TestStop = StopReason 59 | 60 | testStartLinkLocal :: Free TestF Unit 61 | testStartLinkLocal = 62 | test "Can start a locally named GenServer" do 63 | testStartGetSet $ Local $ atom "testStartLinkLocal" 64 | 65 | testStartLinkGlobal :: Free TestF Unit 66 | testStartLinkGlobal = 67 | test "Can start a globally named GenServer" do 68 | testStartGetSet $ Global (unsafeToForeign $ atom "testStartLinkGlobal") 69 | 70 | testStopNormalLocal :: Free TestF Unit 71 | testStopNormalLocal = 72 | mpTest "Can start and stop a locally named GenServer" 73 | $ testStopNormal 74 | $ Local 75 | $ atom "testStopNormalLocal" 76 | 77 | testStopNormalGlobal :: Free TestF Unit 78 | testStopNormalGlobal = 79 | mpTest "Can start and stop a globally named GenServer" 80 | $ testStopNormal 81 | $ Global (unsafeToForeign $ atom "testStopNormalGlobal") 82 | 83 | type TestMonad handledMsg = MonitorT TestMonitorMsg (TrapExitT (ProcessTM TestMsg handledMsg)) 84 | 85 | testMonadStatePassedAround :: Free TestF Unit 86 | testMonadStatePassedAround = 87 | mpTest "Ensure MonadProcessTrans state is maintained across calls" theTest 88 | where 89 | theTest :: ProcessTM Int _ Unit 90 | theTest = do 91 | -- Go through each handler in a GenServer adding a monitor in each and check that they all fire 92 | -- The process we spawn waits 20ms before exit to make sure that all the monitors fire after the 93 | -- setup is complete and we don't just have messages in our process queue masking for the correct state 94 | -- Init (0x01) -> Continue (0x02) -> Info (0x04) -> Monitors and Exits fire -> terminate 95 | me <- self 96 | liftEffect $ void $ crashIfNotStarted <$> GS2.startLink' { init: init me, handleInfo, handleContinue, terminate } 97 | msg <- Process.receive 98 | liftEffect $ assertEqual 99 | { actual: msg 100 | , expected: 0x0F 101 | } 102 | 103 | init :: Process Int -> GS2.InitFn TestCont TestState2 (TestMonad _) 104 | init parentPid = do 105 | _ <- spawnLinkMonitor exitsQuickly $ const (TestMonitorMsg 0x01) 106 | pure $ InitOkContinue { parentPid, total: 0 } TestCont 107 | 108 | handleContinue :: ContinueFn TestCont TestStop TestState2 (TestMonad _) 109 | handleContinue TestCont state = do 110 | -- let _ = spy "handleContinue" state 111 | me <- self 112 | void $ spawnLinkMonitor exitsQuickly $ const (TestMonitorMsg 0x02) 113 | liftEffect $ me ! TestMsg 114 | pure $ GS2.return state 115 | handleContinue (TestContFrom _) state = do 116 | pure $ GS2.return $ state 117 | 118 | handleInfo :: GS2.InfoFn TestCont TestStop _ TestState2 (TestMonad _) 119 | handleInfo (Left msg) state = handleMonitorMsg msg state 120 | handleInfo (Right (Left msg)) state = handleExitMsg msg state 121 | handleInfo (Right (Right msg)) state = handleAppMsg msg state 122 | 123 | handleMonitorMsg (TestMonitorMsg i) state@{ total: x } = do 124 | let 125 | -- _ = spy "handleMonitorMsg" {i, state} 126 | newTotal = x + i 127 | case x of 128 | 0 -> do 129 | void $ spawnLinkMonitor exitsQuickly $ const (TestMonitorMsg 0x08) 130 | pure $ GS2.return $ state { total = newTotal } 131 | _ -> 132 | case newTotal of 133 | 0x0F -> do 134 | pure $ GS2.returnWithAction StopNormal state { total = newTotal } 135 | _ -> 136 | pure $ GS2.return $ state { total = newTotal } 137 | 138 | handleExitMsg _msg state = do 139 | -- let 140 | -- _ = spy "handleExitMsg" {_msg, state} 141 | pure $ GS2.return $ state 142 | 143 | handleAppMsg TestMsg state = do 144 | -- let 145 | -- _ = spy "handleAppMsg" state 146 | 147 | void $ spawnLinkMonitor exitsQuickly $ const (TestMonitorMsg 0x04) 148 | pure $ GS2.return $ state 149 | handleAppMsg _ _state = do 150 | unsafeCrashWith "Unexpected message" 151 | 152 | terminate _reason { parentPid, total } = do 153 | liftEffect $ send parentPid total 154 | 155 | exitsQuickly :: ProcessTM Void _ Unit 156 | exitsQuickly = do 157 | liftEffect $ sleep 20 158 | pure unit 159 | 160 | type TrapExitState = 161 | { testPid :: Process Boolean 162 | , receivedExit :: Boolean 163 | , receivedTerminate :: Boolean 164 | } 165 | 166 | testStartGetSet :: RegistryName TestServerType -> Effect Unit 167 | testStartGetSet registryName = do 168 | let 169 | --gsSpec :: GS2.ServerSpec TestCont TestStop TestMsg _ TestState (ProcessM TestMsg) 170 | gsSpec :: GS2.GSConfig TestCont TestStop _ TestState (ProcessTM _ TestMsg) 171 | gsSpec = 172 | (GS2.defaultSpec init) 173 | { serverName = Just registryName 174 | , handleInfo = Just handleInfo 175 | , handleContinue = Just handleContinue 176 | } 177 | 178 | instanceRef = ByName registryName 179 | serverPid <- crashIfNotStarted <$> (GS2.startLink gsSpec) 180 | maybeServerPid <- GS2.whereIs registryName 181 | assert' "The pid that is looked up should be that returned by start" $ maybeServerPid == Just serverPid 182 | getState instanceRef >>= expectState 0 -- Starts with initial state 0 183 | setState instanceRef (TestState 1) >>= expectState 0 -- Set new as 1, old is 0 184 | getState instanceRef >>= expectState 1 -- Previsouly set state returned 185 | setStateCast instanceRef (TestState 2) -- Set new state async 186 | getState instanceRef >>= expectState 2 -- Previsouly set state returned 187 | getProcess serverPid ! TestMsg -- Trigger HandleInfo to add 100 188 | getState instanceRef >>= expectState 102 -- Previsouly set state returned 189 | callContinueReply instanceRef >>= expectState 102 -- Trigger a continue - returning old state 190 | getState instanceRef >>= expectState 202 -- The continue fires updating state befor the next get 191 | callContinueNoReply instanceRef >>= expectState 202 -- Tigger a continue that replies in the continuation 192 | getState instanceRef >>= expectState 302 -- Post the reply, the continuation updates the state 193 | castContinue instanceRef -- Continues are triggered by casts as well 194 | getState instanceRef >>= expectState 402 -- As evidenced by the updated state 195 | stop instanceRef 196 | pure unit 197 | where 198 | init = do 199 | pure $ InitOk (TestState 0) 200 | 201 | handleInfo TestMsg (TestState x) = do 202 | pure $ GS2.return $ TestState $ x + 100 203 | 204 | handleInfo _ _s = do 205 | unsafeCrashWith "Unexpected message" 206 | 207 | handleContinue cont (TestState x) = 208 | case cont of 209 | TestCont -> pure $ GS2.return $ TestState $ x + 100 210 | TestContFrom from -> do 211 | GS2.replyTo from (TestState x) 212 | pure $ GS2.return $ TestState $ x + 100 213 | 214 | callContinueReply handle = GS2.call handle \_from state -> pure $ GS2.replyWithAction state (Continue TestCont) state 215 | 216 | callContinueNoReply handle = GS2.call handle \from state -> pure $ GS2.noReplyWithAction (Continue $ TestContFrom from) state 217 | 218 | castContinue handle = GS2.cast handle \state -> pure $ GS2.returnWithAction (Continue TestCont) state 219 | 220 | stop = GS2.stop 221 | 222 | data TestMonitorMsg = TestMonitorMsg Int 223 | 224 | derive instance Eq TestMonitorMsg 225 | instance Show TestMonitorMsg where 226 | show (TestMonitorMsg i) = "TestMonitorMsg: " <> show i 227 | 228 | testStopNormal :: RegistryName TestServerType -> MonitorT TestMonitorMsg (ProcessTM Void (Either TestMonitorMsg Void)) Unit 229 | testStopNormal registryName = do 230 | let 231 | gsSpec :: GS2.GSConfig TestCont TestStop _ TestState (ProcessTM TestMsg _) 232 | gsSpec = 233 | (GS2.defaultSpec init) 234 | { serverName = Just registryName 235 | , handleInfo = Just handleInfo 236 | , handleContinue = Just handleContinue 237 | } 238 | instanceRef = ByName registryName 239 | serverPid <- liftEffect $ crashIfNotStarted <$> (GS2.startLink gsSpec) 240 | _ <- monitor (toPid $ getProcess serverPid) $ const (TestMonitorMsg 0) 241 | liftEffect do 242 | getState instanceRef >>= expectState 0 -- Starts with initial state 0 243 | -- Try to start the server again - should fail with already running 244 | (GS2.startLink gsSpec) <#> isAlreadyRunning >>= expect true 245 | triggerStopCast instanceRef 246 | msg <- receive 247 | liftEffect do 248 | expect msg (Left (TestMonitorMsg 0)) 249 | void $ crashIfNotStarted <$> (GS2.startLink gsSpec) 250 | (GS2.startLink gsSpec) <#> isAlreadyRunning >>= expect true 251 | triggerStopCallReply instanceRef >>= expectState 42 -- New instance starts with initial state 0 252 | void $ crashIfNotStarted <$> (GS2.startLink gsSpec) 253 | getState instanceRef >>= expectState 0 -- New instance starts with initial state 0 254 | -- TODO trigger stop from a handle_info 255 | triggerStopCast instanceRef 256 | pure unit 257 | 258 | where 259 | init = do 260 | pure $ InitOk (TestState 0) 261 | 262 | handleInfo TestMsg (TestState x) = do 263 | pure $ GS2.return $ TestState $ x + 100 264 | 265 | handleInfo _ _s = do 266 | unsafeCrashWith "Unexpected message" 267 | 268 | handleContinue :: GS2.ContinueFn _ _ _ _ 269 | handleContinue cont (TestState x) = 270 | case cont of 271 | TestCont -> pure $ GS2.return $ TestState $ x + 100 272 | TestContFrom from -> do 273 | GS2.replyTo from (TestState x) 274 | pure $ GS2.return $ TestState $ x + 100 275 | 276 | triggerStopCast handle = GS2.cast handle \state -> pure $ GS2.returnWithAction StopNormal state 277 | 278 | triggerStopCallReply handle = GS2.call handle \_from state -> pure $ GS2.replyWithAction (TestState 42) StopNormal state 279 | 280 | --------------------------------------------------------------------------------- 281 | -- Internal 282 | --------------------------------------------------------------------------------- 283 | isAlreadyRunning :: forall serverType. StartLinkResult serverType -> Boolean 284 | isAlreadyRunning = case _ of 285 | Left (AlreadyStarted _) -> true 286 | _ -> false 287 | 288 | expectState :: Int -> TestState -> Effect Unit 289 | expectState expected actual = assertEqual { actual, expected: TestState expected } 290 | 291 | expect :: forall a. Eq a => Show a => a -> a -> Effect Unit 292 | expect expected actual = assertEqual { actual, expected: expected } 293 | 294 | -------------------------------------------------------------------------------- /test/GenServer2.purs: -------------------------------------------------------------------------------- 1 | module Test.GenServer2 2 | ( genServer2Suite 3 | ) where 4 | 5 | import Prelude 6 | 7 | import Control.Monad.Free (Free) 8 | import Data.Either (Either(..)) 9 | import Data.Time.Duration (Milliseconds(..)) 10 | import Effect.Class (liftEffect) 11 | import Erl.Process (Process, getProcess, self, send, (!), unsafeRunProcessM) 12 | import Erl.Process as Legacy 13 | import Erl.Test.EUnit (TestF, suite, test) 14 | import Partial.Unsafe (unsafeCrashWith) 15 | import Pinto.GenServer2 (InitResult(..)) 16 | import Pinto.GenServer2 as GS2 17 | import Erl.ProcessT (ProcessTM, ProcessM, receiveWithTimeout, spawnLink) 18 | import Erl.ProcessT.MonitorT (MonitorT) 19 | import Erl.ProcessT.TrapExitT (TrapExitT, ExitMessage(..)) 20 | import Pinto.Types (RegistryReference(..), crashIfNotStarted) 21 | import Test.Assert (assertEqual, assertEqual') 22 | import Test.TestHelpers (getState, mpTest, setState, setStateCast) 23 | 24 | genServer2Suite :: Free TestF Unit 25 | genServer2Suite = 26 | suite "Pinto genServer tests" do 27 | testStartLinkAnonymous 28 | testHandleInfo 29 | testCall 30 | testCast 31 | testTrapExits 32 | 33 | data TestState = TestState Int 34 | 35 | derive instance eqTestState :: Eq TestState 36 | 37 | instance showTestState :: Show TestState where 38 | show (TestState x) = "TestState: " <> show x 39 | 40 | type TestState2 = 41 | { total :: Int 42 | , parentPid :: Process Int 43 | } 44 | 45 | data TestMsg 46 | = TestMsg 47 | | TestMsgNotSent 48 | 49 | testStartLinkAnonymous :: Free TestF Unit 50 | testStartLinkAnonymous = 51 | test "Can start an anonymous GenServer" do 52 | serverPid <- crashIfNotStarted <$> GS2.startLink' { init } 53 | let 54 | instanceRef = ByPid serverPid 55 | state1 <- getState instanceRef 56 | state2 <- setState instanceRef (TestState 1) 57 | state3 <- getState instanceRef 58 | setStateCast instanceRef (TestState 2) 59 | state4 <- getState instanceRef 60 | assertEqual { actual: state1, expected: TestState 0 } 61 | assertEqual { actual: state2, expected: TestState 0 } 62 | assertEqual { actual: state3, expected: TestState 1 } 63 | assertEqual { actual: state4, expected: TestState 2 } 64 | pure unit 65 | where 66 | init :: GS2.InitFn TestState (ProcessTM Void Void) 67 | init = pure $ GS2.InitOk (TestState 0) 68 | 69 | testHandleInfo :: Free TestF Unit 70 | testHandleInfo = 71 | test "HandleInfo handler receives message" do 72 | serverPid <- crashIfNotStarted <$> GS2.startLink' { init, handleInfo } 73 | getProcess serverPid ! TestMsg 74 | state <- getState (ByPid serverPid) 75 | assertEqual 76 | { actual: state 77 | , expected: TestState 1 78 | } 79 | pure unit 80 | where 81 | init :: GS2.InitFn TestState (ProcessTM TestMsg TestMsg) 82 | init = do 83 | pure $ GS2.InitOk $ TestState 0 84 | 85 | handleInfo TestMsg (TestState x) = do 86 | pure $ GS2.return $ TestState $ x + 1 87 | 88 | handleInfo _ _s = do 89 | unsafeCrashWith "Unexpected message" 90 | 91 | type TestMonad = MonitorT TestMonitorMsg (TrapExitT (ProcessTM TestMsg TestMsg)) 92 | 93 | testCall :: Free TestF Unit 94 | testCall = 95 | test "Can create gen_server:call handlers" do 96 | serverPid <- crashIfNotStarted <$> (GS2.startLink $ GS2.defaultSpec init) 97 | state <- getState (ByPid serverPid) 98 | assertEqual 99 | { actual: state 100 | , expected: TestState 7 101 | } 102 | pure unit 103 | where 104 | init :: GS2.InitFn TestState (ProcessM Void) 105 | init = do 106 | pure $ InitOk $ TestState 7 107 | 108 | testCast :: Free TestF Unit 109 | testCast = 110 | test "HandleCast changes state" do 111 | serverPid <- crashIfNotStarted <$> (GS2.startLink $ (GS2.defaultSpec init)) 112 | setStateCast (ByPid serverPid) $ TestState 42 113 | state <- getState (ByPid serverPid) 114 | assertEqual 115 | { actual: state 116 | , expected: TestState 42 117 | } 118 | pure unit 119 | where 120 | init :: GS2.InitFn TestState (ProcessM Void) 121 | init = do 122 | pure $ InitOk $ TestState 0 123 | 124 | type TrapExitState = 125 | { testPid :: Process Boolean 126 | , receivedExit :: Boolean 127 | , receivedTerminate :: Boolean 128 | } 129 | 130 | testTrapExits :: Free TestF Unit 131 | testTrapExits = 132 | suite "Trapped exits" do 133 | mpTest "Children's exits get translated when requested" testChildExit 134 | mpTest "Parent exits arrive in the terminate callback" testParentExit 135 | 136 | where 137 | testChildExit :: ProcessM Void Unit 138 | testChildExit = liftEffect do 139 | serverPid <- crashIfNotStarted <$> (GS2.startLink' { init, handleInfo }) 140 | 141 | let waitForValidState = do 142 | state <- getState (ByPid serverPid) 143 | if state.receivedExit then pure state 144 | else do 145 | unsafeRunProcessM do 146 | _ <- Legacy.receiveWithTimeout (Milliseconds 50.0) unit 147 | pure unit 148 | waitForValidState 149 | 150 | state <- waitForValidState 151 | 152 | assertEqual 153 | { actual: state.receivedExit 154 | , expected: true 155 | } 156 | pure unit 157 | 158 | testParentExit :: ProcessM Boolean Unit 159 | testParentExit = do 160 | testPid <- self 161 | let 162 | spawnAndExit :: ProcessM Void Unit 163 | spawnAndExit = void $ liftEffect $ crashIfNotStarted <$> (GS2.startLink' $ { init: init2 testPid, terminate }) 164 | 165 | void $ liftEffect $ spawnLink spawnAndExit 166 | actual <- receiveWithTimeout (Milliseconds 50.0) 167 | liftEffect $ assertEqual' "Terminate wasn't called on the genserver" { expected: Right true, actual } 168 | 169 | init :: GS2.InitFn _ (TrapExitT (ProcessTM Void _)) 170 | init = do 171 | pid <- liftEffect $ spawnLink exitsImmediately 172 | pure $ InitOk $ { testPid: pid, receivedExit: false, receivedTerminate: false } 173 | 174 | init2 :: Process Boolean -> GS2.InitFn TrapExitState (TrapExitT (ProcessTM Void _)) 175 | init2 pid = do 176 | pure $ InitOk $ { testPid: pid, receivedExit: false, receivedTerminate: false } 177 | 178 | handleInfo (Left (Exit _ _)) s = do 179 | pure $ GS2.return $ s { receivedExit = true } 180 | 181 | handleInfo _ _s = do 182 | unsafeCrashWith "Unexpected message" 183 | 184 | terminate _reason s = do 185 | liftEffect $ send s.testPid true 186 | 187 | data TestMonitorMsg = TestMonitorMsg Int 188 | 189 | derive instance Eq TestMonitorMsg 190 | instance Show TestMonitorMsg where 191 | show (TestMonitorMsg i) = "TestMonitorMsg: " <> show i 192 | 193 | --------------------------------------------------------------------------------- 194 | -- Internal 195 | --------------------------------------------------------------------------------- 196 | exitsImmediately :: forall handledMsg. ProcessTM Void handledMsg Unit 197 | exitsImmediately = do 198 | pure unit 199 | -------------------------------------------------------------------------------- /test/Main.erl: -------------------------------------------------------------------------------- 1 | -module(test_main@foreign). 2 | -export([filterSasl/0]). 3 | 4 | filterSasl() -> fun () -> 5 | Level = case os:getenv("LOG") of 6 | false -> none; 7 | Val -> list_to_atom(Val) 8 | end, 9 | logger:set_primary_config(level, Level), 10 | logger:set_handler_config(default, formatter, {logger_formatter, #{legacy_header => false, single_line => true, depth => 20}}), 11 | logger:add_primary_filter(sasl, {fun logger_filters:domain/2, {stop, sub, [otp, sasl]}}) 12 | end. 13 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Free (Free) 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Time.Duration (Milliseconds(..), Seconds(..)) 8 | import Effect (Effect) 9 | import Erl.Atom (atom) 10 | import Erl.Data.List (nil, (:)) 11 | import Erl.Kernel.Application (ensureAllStarted) 12 | import Erl.ProcessT (ProcessM) 13 | import Erl.Test.EUnit (TestF, runTests, suite, test) 14 | import Pinto (StartLinkResult) 15 | import Pinto.GenServer2 (InitFn, InitResult(..), ServerPid) 16 | import Pinto.GenServer2 as GS2 17 | import Pinto.Supervisor (ChildShutdownTimeoutStrategy(..), ChildType(..), RestartStrategy(..), Strategy(..), SupervisorSpec, ChildSpec, spec) 18 | import Pinto.Supervisor as Sup 19 | import Pinto.Supervisor.SimpleOneForOne as DynamicSup 20 | import Pinto.Types (RegistryName(..), RegistryReference(..), crashIfNotStarted) 21 | import Test.Assert (assertEqual) 22 | import Test.DoorLock as DoorLock 23 | import Test.GenServer as TGS 24 | import Test.GenServer2 as TGS2 25 | import Test.TestHelpers (getState) 26 | import Test.ValueServer (testValueServer) 27 | 28 | foreign import filterSasl :: Effect Unit 29 | 30 | main :: Effect Unit 31 | main = do 32 | filterSasl 33 | void $ ensureAllStarted $ atom "gproc" 34 | void $ runTests do 35 | TGS.genServerSuite 36 | TGS2.genServer2Suite 37 | DoorLock.testSuite 38 | testValueServer 39 | 40 | -- testValueServer 41 | -- DoorLock.testSuite 42 | -- supervisorSuite 43 | 44 | supervisorSuite :: Free TestF Unit 45 | supervisorSuite = 46 | suite "Pinto supervisor tests" do 47 | testStartWithNamedChild 48 | dynamicSupervisor 49 | 50 | data TestState = TestState Int 51 | 52 | derive instance eqTestState :: Eq TestState 53 | 54 | instance showTestState :: Show TestState where 55 | show (TestState x) = "TestState: " <> show x 56 | 57 | data TestCont = TestCont 58 | 59 | data TestMsg = TestMsg 60 | 61 | -------------------------------------------------------------------------------- 62 | -- Standard Supervisor Test 63 | -------------------------------------------------------------------------------- 64 | testStartWithNamedChild :: Free TestF Unit 65 | testStartWithNamedChild = 66 | test "Can start a supervisor with a single named child" do 67 | _supPid <- crashIfNotStarted <$> Sup.startLink Nothing supInit 68 | childState <- getState $ ByName childName 69 | assertEqual 70 | { actual: childState 71 | , expected: TestState 0 72 | } 73 | pure unit 74 | where 75 | childSpecs = 76 | spec myChild 77 | : nil 78 | 79 | supInit :: Effect SupervisorSpec 80 | supInit = 81 | pure 82 | { flags: 83 | { strategy: OneForOne 84 | , intensity: 1 85 | , period: Seconds 5.0 86 | } 87 | , childSpecs 88 | } 89 | 90 | childInit :: InitFn TestState (ProcessM Void) 91 | childInit = do 92 | pure $ InitOk $ TestState 0 93 | 94 | childName = Local $ atom "testNamedChild" 95 | 96 | --myChild :: ChildSpec String TestState TestMsg 97 | myChild = mkChildSpec "myChildId" (GS2.startLink $ (GS2.defaultSpec childInit) { serverName = Just childName }) 98 | 99 | mkChildSpec :: forall childType. String -> Effect (StartLinkResult childType) -> ChildSpec childType 100 | mkChildSpec id start = 101 | { id 102 | , childType: Worker 103 | , start 104 | , restartStrategy: RestartTemporary 105 | , shutdownStrategy: ShutdownTimeout $ Milliseconds 5000.0 106 | } 107 | 108 | -------------------------------------------------------------------------------- 109 | -- Dynamic Supervisor Test 110 | -------------------------------------------------------------------------------- 111 | dynamicSupervisor :: Free TestF Unit 112 | dynamicSupervisor = 113 | test "Can start a supervisor and add a child" do 114 | supPid <- crashIfNotStarted <$> DynamicSup.startLink Nothing supInit 115 | childPid <- Sup.crashIfChildNotStarted <$> DynamicSup.startChild (ByPid supPid) unit 116 | childState <- getState (ByPid childPid) 117 | assertEqual 118 | { actual: childState 119 | , expected: TestState 0 120 | } 121 | pure unit 122 | where 123 | supInit :: Effect (DynamicSup.ChildSpec Unit (ServerPid TestState (ProcessM Void))) 124 | supInit = 125 | pure 126 | { intensity: 1 127 | , period: Seconds 5.0 128 | , childType: Worker 129 | , start: childStart 130 | , restartStrategy: RestartTemporary 131 | , shutdownStrategy: ShutdownTimeout $ Milliseconds 5000.0 132 | } 133 | 134 | childStart _ = GS2.startLink $ (GS2.defaultSpec childInit) 135 | 136 | childInit :: InitFn TestState (ProcessM Void) 137 | childInit = do 138 | pure $ InitOk $ TestState 0 139 | -------------------------------------------------------------------------------- /test/TestHelpers.erl: -------------------------------------------------------------------------------- 1 | -module(test_testHelpers@foreign). 2 | 3 | -export([ sleep/1 4 | ]). 5 | 6 | sleep(Ms) -> 7 | fun() -> 8 | timer:sleep(Ms), 9 | unit 10 | end. 11 | -------------------------------------------------------------------------------- /test/TestHelpers.purs: -------------------------------------------------------------------------------- 1 | module Test.TestHelpers 2 | ( getState 3 | , mpTest 4 | , setState 5 | , setStateCast 6 | , sleep 7 | ) where 8 | 9 | import Prelude 10 | 11 | import Control.Monad.Free (Free) 12 | import Effect (Effect) 13 | import Erl.Test.EUnit (TestF, test) 14 | import Pinto.GenServer.ContStop as GS 15 | import Erl.ProcessT (class MonadProcessHandled, class MonadProcessRun, class MonadProcessTrans, unsafeEvalProcess) 16 | 17 | mpTest 18 | :: forall m mState appMsg parsedMsg 19 | . MonadProcessRun Effect m mState appMsg parsedMsg 20 | => MonadProcessHandled m parsedMsg 21 | => String 22 | -> m Unit 23 | -> Free TestF Unit 24 | mpTest desc mpt = test desc $ unsafeEvalProcess mpt 25 | 26 | foreign import sleep :: Int -> Effect Unit 27 | 28 | getState 29 | :: forall cont stop appMsg parsedMsg state m mState 30 | . MonadProcessTrans m mState appMsg parsedMsg 31 | => Monad m 32 | => GS.ServerRef cont stop state m 33 | -> Effect state 34 | getState handle = 35 | GS.call handle callFn 36 | where 37 | callFn :: GS.CallFn state cont stop state m 38 | callFn _from state = 39 | pure $ GS.reply state state 40 | 41 | setState 42 | :: forall cont stop appMsg parsedMsg state m mState 43 | . MonadProcessTrans m mState appMsg parsedMsg 44 | => Monad m 45 | => GS.ServerRef cont stop state m 46 | -> state 47 | -> Effect state 48 | setState handle newState = 49 | GS.call handle callFn 50 | where 51 | callFn :: GS.CallFn state cont stop state m 52 | callFn _from oldState = 53 | pure $ GS.reply oldState newState 54 | 55 | setStateCast 56 | :: forall cont stop appMsg parsedMsg state m mState 57 | . MonadProcessTrans m mState appMsg parsedMsg 58 | => Monad m 59 | => GS.ServerRef cont stop state m 60 | -> state 61 | -> Effect Unit 62 | setStateCast handle newState = GS.cast handle castFn 63 | where 64 | castFn :: GS.CastFn cont stop state m 65 | castFn _state = pure $ GS.return newState 66 | -------------------------------------------------------------------------------- /test/ValueServer.purs: -------------------------------------------------------------------------------- 1 | module Test.ValueServer 2 | ( Msg 3 | , ValueServerPid 4 | , getValue 5 | , setValue 6 | , setValueAsync 7 | , startLink 8 | , stop 9 | , testValueServer 10 | ) where 11 | 12 | import Prelude 13 | 14 | import Control.Monad.Free (Free) 15 | import Effect (Effect) 16 | import Erl.Atom (atom) 17 | import Erl.Process.Raw (class HasPid) 18 | import Erl.Test.EUnit (TestF, test) 19 | import Pinto.GenServer2 (InitFn, InitResult(..), ServerPid, ServerType) 20 | import Pinto.GenServer2 as GS 21 | import Erl.ProcessT (ProcessM) 22 | import Pinto.Types (RegistryName(..), RegistryReference(..), crashIfNotStarted) 23 | import Test.Assert (assertEqual) 24 | 25 | data Msg = SetValue Int 26 | 27 | type State = { value :: Int } 28 | 29 | type ValueServerType = ServerType State (ProcessM Msg) 30 | 31 | newtype ValueServerPid = ValueServerPid (ServerPid State (ProcessM Msg)) 32 | 33 | -- Only surface the raw pid, don't implement HasProcess - we don't want folks sending us messages using our Info 34 | -- type 35 | derive newtype instance valueServerPidHasPid :: HasPid ValueServerPid 36 | 37 | serverName :: RegistryName ValueServerType 38 | serverName = Local $ atom "valueServer" 39 | 40 | startLink :: Effect ValueServerPid 41 | startLink = do 42 | ValueServerPid 43 | <$> crashIfNotStarted 44 | <$> (GS.startLink' { serverName, init }) 45 | where 46 | init :: InitFn State (ProcessM Msg) 47 | init = 48 | let 49 | state = { value: 0 } 50 | in 51 | pure $ InitOk state 52 | 53 | getValue :: Effect Int 54 | getValue = GS.call (ByName serverName) impl 55 | where 56 | impl _from state@{ value } = pure $ GS.reply value state 57 | 58 | setValue :: Int -> Effect Int 59 | setValue n = GS.call (ByName serverName) impl 60 | where 61 | impl _from state@{ value } = pure $ GS.reply value state { value = n } 62 | 63 | setValueAsync :: Int -> Effect Unit 64 | setValueAsync n = GS.cast (ByName serverName) impl 65 | where 66 | impl state = pure $ GS.return state { value = n } 67 | 68 | stop :: Effect Unit 69 | stop = GS.stop (ByName serverName) 70 | 71 | -------------------------------------------------------------------------------- 72 | -- Tests 73 | -------------------------------------------------------------------------------- 74 | testValueServer :: Free TestF Unit 75 | testValueServer = 76 | test "Interaction with gen_server with closed API" do 77 | void $ startLink 78 | void $ setValue 42 79 | v1 <- setValue 43 80 | v2 <- getValue 81 | setValueAsync 50 82 | v3 <- getValue 83 | stop 84 | assertEqual { actual: v1, expected: 42 } 85 | assertEqual { actual: v2, expected: 43 } 86 | assertEqual { actual: v3, expected: 50 } 87 | pure unit 88 | -------------------------------------------------------------------------------- /test/rebar3.config: -------------------------------------------------------------------------------- 1 | {erl_opts, 2 | [ debug_info 3 | ]}. 4 | 5 | {deps, [ 6 | ]}. 7 | 8 | {pre_hooks, 9 | [ {"(linux|darwin|solaris|win32)", compile, "bash -c 'cd .. && make'"} 10 | , {"(linux|darwin|solaris|win32)", clean, "cd .. && make clean"} 11 | ]}. 12 | -------------------------------------------------------------------------------- /thoughts.md: -------------------------------------------------------------------------------- 1 | 74e58d0db7f2b7cfa7b7e0a9e47281a75b971e3a - deletes Monitor.purs 2 | da4b9ce59aa52343796327a12e87231d06b8bed0 - deletes Timer.purs 3 | 4 | 5 | Why is Process.runProcess called runProcess? it doesn't have any side effect, it just extracts a Pid. 6 | 7 | 8 | Why is the constructor for the Process newtype directly public?? surely we should have an unsafeProcessFromPid function or something? 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | GenStatem should return 17 | `GenStatemProcess (GenStatemType info internal timerName timerContent commonData stateId state)` 18 | 19 | where 20 | GenStatemType is a newtype of `Void` 21 | GenStatemProcess is a newtype of `Process info` 22 | 23 | GenStatemProcess exposes 24 | HasRawPid (getRawPid) 25 | HasProcess (getProcess) (not sure if this should be an unwrap?) 26 | 27 | StartLinkResult success should be not `ServerPid serverType` but `serverProcess`, `ServerPid` should be removed. 28 | 29 | 30 | Sup should constrain serverProcess to a `HasRawPid` type class so that it can get the pid to monitor - the same for StartChild 31 | 32 | ``` 33 | data InstanceRef serverType 34 | = ByName (RegistryName serverType) 35 | ByPid (ServerPid serverType) 36 | ``` 37 | 38 | becomes 39 | 40 | ``` 41 | data InstanceRef serverType serverProcess 42 | = ByName (RegistryName serverType) 43 | | ByProcess (ServerProcess serverType) 44 | ``` 45 | 46 | Now the Statem/Server has complete control over its own Pid and can surface what it likes with it, because it can 47 | just newtype of the core Statem/Server type - for a Sup, it merely needs to support `HasRawPid` which can be 48 | generated using `newtype deriving` 49 | 50 | 51 | 52 | Timers operate over (HasProcess) 53 | 54 | 55 | Monitors operate over (HasRawPid) 56 | 57 | 58 | 59 | Why? 60 | 61 | 62 | Because the statem/server needs to provide facilities to take its "pid" and do useful things with it (e.g. for timers), and 63 | those APIs are callable by anyone, so whatever pid the statem/server provides should not be returned directly 64 | by the statem/server implementation to API consumers, they should return their own thing so that they can 65 | control what an API consumer can do with it. 66 | 67 | For example, just because a server/statem implementation is using `info`, it doesn't mean that they want 68 | an API consumer to be able to send those `info` messages to the server/statem. 69 | 70 | 71 | 72 | 73 | 74 | 75 | Process mapping? spawn a small process that receives messages, transforms them, and forwards them? 76 | 77 | 78 | Should GenStatem/GenServer expose their own monitor functions? 79 | 80 | 81 | 82 | 83 | 84 | Consistency 85 | - ServerSpec vs Spec (for Statem) - it's unlikely folks would be using both in a single module, so the short names are better? 86 | 87 | 88 | 89 | Unfinished 90 | - Terminate handling 91 | - Monitor handling should be the same I think 92 | 93 | 94 | newtype Blah = Blah Void 95 | 96 | newtype FooPid statemType = FooPid Void 97 | 98 | class HasInfoType statemType infoType | statemType -> infoType 99 | 100 | f :: 101 | forall statemType infoType. HasInfoType statemType infoType => 102 | FooPid statemType -> 103 | infoType -> 104 | Effect Unit 105 | 106 | f statemPid info = pure unit 107 | 108 | --------------------------------------------------------------------------------