├── .devcontainer ├── Dockerfile └── devcontainer.json ├── .github └── workflows │ ├── ci.yml │ └── hexpm-release.yml ├── .gitignore ├── .vscode ├── settings.json └── tasks.json ├── CHANGELOG.md ├── CODE_OF_CONDUCT.md ├── CONTRIBUTING.md ├── LICENSE.txt ├── Makefile ├── README.md ├── include └── p1_queue.hrl ├── rebar.config ├── rebar.config.script ├── rebar.lock ├── src ├── p1_file_queue.erl ├── p1_fsm.erl ├── p1_http.erl ├── p1_nif_utils.erl ├── p1_options.erl ├── p1_prof.erl ├── p1_proxy_protocol.erl ├── p1_queue.erl ├── p1_rand.erl ├── p1_server.erl ├── p1_shaper.erl ├── p1_time_compat.erl ├── p1_utils.app.src ├── p1_utils.erl ├── p1_utils_sup.erl └── treap.erl └── test └── p1_queue_test.erl /.devcontainer/Dockerfile: -------------------------------------------------------------------------------- 1 | # Tag version from https://hub.docker.com/_/erlang 2 | ARG TAG=23 3 | FROM erlang:${TAG} 4 | -------------------------------------------------------------------------------- /.devcontainer/devcontainer.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "Erlang", 3 | "build": { 4 | "dockerfile": "Dockerfile", 5 | "args": { 6 | "TAG": "23", 7 | } 8 | }, 9 | 10 | // Set *default* container specific settings.json values on container create. 11 | "settings": { 12 | "terminal.integrated.shell.linux": "/bin/bash", 13 | }, 14 | 15 | // Add the IDs of extensions you want installed when the container is created. 16 | "extensions": [ 17 | "pgourlain.erlang", 18 | "garaemon.vscode-emacs-tab" 19 | ], 20 | 21 | // Comment out connect as root instead. More info: https://aka.ms/vscode-remote/containers/non-root. 22 | // "remoteUser": "vscode" 23 | } -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | 7 | tests: 8 | name: Tests 9 | strategy: 10 | fail-fast: false 11 | matrix: 12 | otp: [20, 25, 26, 27] 13 | runs-on: ubuntu-24.04 14 | container: 15 | image: erlang:${{ matrix.otp }} 16 | steps: 17 | - uses: actions/checkout@v4 18 | - run: adduser tester && chown -R tester . 19 | - run: su tester -c "make" 20 | - run: su tester -c "rebar3 compile" 21 | - run: su tester -c "rebar3 xref" 22 | - run: su tester -c "rebar3 dialyzer" 23 | - run: su tester -c "rebar3 eunit -v" 24 | - name: Send to Coveralls 25 | if: matrix.otp == 24 26 | env: 27 | GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} 28 | run: | 29 | COVERALLS=true rebar3 as test coveralls send 30 | curl -v -k https://coveralls.io/webhook \ 31 | --header "Content-Type: application/json" \ 32 | --data '{"repo_name":"$GITHUB_REPOSITORY", 33 | "repo_token":"$GITHUB_TOKEN", 34 | "payload":{"build_num":$GITHUB_RUN_ID, 35 | "status":"done"}}' 36 | -------------------------------------------------------------------------------- /.github/workflows/hexpm-release.yml: -------------------------------------------------------------------------------- 1 | name: Hex 2 | 3 | on: 4 | push: 5 | tags: 6 | - '*' 7 | 8 | jobs: 9 | release: 10 | runs-on: ubuntu-24.04 11 | steps: 12 | 13 | - name: Check out 14 | uses: actions/checkout@v4 15 | 16 | - name: Get Erlang/OTP 17 | uses: erlef/setup-beam@v1 18 | with: 19 | otp-version: 27 20 | rebar3-version: '3.24.0' 21 | 22 | - name: Generate documentation 23 | run: rebar3 edoc 24 | 25 | - name: Setup rebar3 hex 26 | run: | 27 | mkdir -p ~/.config/rebar3/ 28 | echo "{plugins, [rebar3_hex]}." > ~/.config/rebar3/rebar.config 29 | 30 | - run: rebar3 edoc 31 | 32 | - name: Prepare Markdown 33 | run: | 34 | echo "" >>README.md 35 | echo "## EDoc documentation" >>README.md 36 | echo "" >>README.md 37 | echo "You can check this library's " >>README.md 38 | echo "[EDoc documentation](edoc.html), " >>README.md 39 | echo "generated automatically from the source code comments." >>README.md 40 | 41 | - name: Convert Markdown to HTML 42 | uses: natescherer/markdown-to-html-with-github-style-action@v1.1.0 43 | with: 44 | path: README.md 45 | 46 | - run: | 47 | mv doc/index.html doc/edoc.html 48 | mv README.html doc/index.html 49 | 50 | - name: Publish to hex.pm 51 | run: DEBUG=1 rebar3 hex publish --repo hexpm --yes 52 | env: 53 | HEX_API_KEY: ${{ secrets.HEX_API_KEY }} 54 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.swo 2 | *.swp 3 | .eunit 4 | .rebar 5 | _build 6 | autom4te.cache 7 | c_src/*.d 8 | c_src/*.gcda 9 | c_src/*.gcno 10 | c_src/*.o 11 | config.log 12 | config.status 13 | deps 14 | doc 15 | ebin 16 | priv 17 | rebar.lock 18 | test/*.beam 19 | vars.config 20 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "erlang.codeLensEnabled": true, 3 | "erlang.linting": true, 4 | "workbench.colorTheme": "Default Dark+" 5 | } -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "2.0.0", 3 | "tasks": [ 4 | { 5 | "label": "rebar3 compile", 6 | "type": "shell", 7 | "command": "rebar3 compile", 8 | "group": { 9 | "kind": "build", 10 | "isDefault": true 11 | }, 12 | "problemMatcher": "$erlang" 13 | } 14 | ] 15 | } -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Version 1.0.27 2 | 3 | * Fix issues with dialyzer on OTP26 4 | 5 | # Version 1.0.26 6 | 7 | * Fix tests issue on OTP26 8 | 9 | # Version 1.0.25 10 | 11 | * Generate docs when publishing to hex.pm 12 | * Add missing `compiler` dependency 13 | * Improve function specs 14 | 15 | # Version 1.0.24 16 | 17 | * Add module for decoding HAproxy protocol (v1 and v2) headers 18 | 19 | # Version 1.0.23 20 | 21 | * Switch from using Travis to Github Actions as CI 22 | * Update .gitignore 23 | * Fix compatibility problems with OTP24 24 | 25 | # Version 1.0.22 26 | 27 | * Update copyright year to 2021 28 | * Unit tests + plugin in release workflow 29 | * Support Docker + VScode development 30 | 31 | # Version 1.0.21 32 | 33 | * Update travis config 34 | 35 | # Version 1.0.19 36 | 37 | * Fix compatibility issues with Erlang 23 38 | 39 | # Version 1.0.18 40 | 41 | * Update copyright year 42 | 43 | # Version 1.0.17 44 | 45 | * Fix formatting of error messages 46 | 47 | # Version 1.0.16 48 | 49 | * Update type specs 50 | * Avoid lengthy output of p1\_prof:m/r/q commands 51 | 52 | # Version 1.0.15 53 | 54 | * Add p1\_prof module 55 | 56 | # Version 1.0.14 57 | 58 | * Add contribution guide 59 | * Remove exec bit from doc/style.css 60 | 61 | # Version 1.0.13 62 | 63 | * Add p1\_rand and shaper module 64 | 65 | # Version 1.0.12 66 | 67 | * Don't fetch generic\_debug option from init 68 | 69 | # Version 1.0.11 70 | 71 | * Fix compilation with rebar3 72 | 73 | # Version 1.0.10 74 | 75 | * Fix problem with edoc 76 | 77 | # Version 1.0.9 78 | 79 | * Add p1_options module 80 | 81 | # Version 1.0.8 82 | 83 | * Add p1_queue 84 | * Only perform destructive operations in p1_file_queue:in/2 85 | * Add garbage collector for file queues 86 | * Add ram_to_file/1 and file_to_ram/1 87 | * Improve exception names 88 | * Implement limited queues 89 | * Add ownership protection 90 | * Add get_limit/1 and set_limit/2 91 | 92 | # Version 1.0.7 93 | 94 | * Fix coverall invocation (Paweł Chmielowski) 95 | * Fix p1_server timeout handling, R18 compatibility (Alexey Shchepin) 96 | 97 | # Version 1.0.6 98 | 99 | * Add p1_http 100 | 101 | # Version 1.0.5 102 | 103 | * Erlang R19 compliance (Paweł Chmielowski) 104 | 105 | # Version 1.0.4 106 | 107 | * Adds p1_time_compat:unique_timestamp() that returns value resembling what now() was returning 108 | 109 | # Version 1.0.3 110 | 111 | * Added time related compatibility module, added API documentation (Paweł Chmielowski) 112 | * Improve documentation readability (Marek Foss) 113 | 114 | # Version 1.0.2 115 | 116 | * Add p1_time_compat module to ease support for both R17 and R18 117 | Erlang time features (Paweł Chmielowski) 118 | 119 | # Version 1.0.1 120 | 121 | * Better Rebar3 support, remove warning about missing hex plugin when 122 | building with rebar (Mickaël Rémond) 123 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Contributor Covenant Code of Conduct 2 | 3 | ## Our Pledge 4 | 5 | In the interest of fostering an open and welcoming environment, we as 6 | contributors and maintainers pledge to making participation in our project and 7 | our community a harassment-free experience for everyone, regardless of age, body 8 | size, disability, ethnicity, sex characteristics, gender identity and expression, 9 | level of experience, education, socio-economic status, nationality, personal 10 | appearance, race, religion, or sexual identity and orientation. 11 | 12 | ## Our Standards 13 | 14 | Examples of behavior that contributes to creating a positive environment 15 | include: 16 | 17 | * Using welcoming and inclusive language 18 | * Being respectful of differing viewpoints and experiences 19 | * Gracefully accepting constructive criticism 20 | * Focusing on what is best for the community 21 | * Showing empathy towards other community members 22 | 23 | Examples of unacceptable behavior by participants include: 24 | 25 | * The use of sexualized language or imagery and unwelcome sexual attention or 26 | advances 27 | * Trolling, insulting/derogatory comments, and personal or political attacks 28 | * Public or private harassment 29 | * Publishing others' private information, such as a physical or electronic 30 | address, without explicit permission 31 | * Other conduct which could reasonably be considered inappropriate in a 32 | professional setting 33 | 34 | ## Our Responsibilities 35 | 36 | Project maintainers are responsible for clarifying the standards of acceptable 37 | behavior and are expected to take appropriate and fair corrective action in 38 | response to any instances of unacceptable behavior. 39 | 40 | Project maintainers have the right and responsibility to remove, edit, or 41 | reject comments, commits, code, wiki edits, issues, and other contributions 42 | that are not aligned to this Code of Conduct, or to ban temporarily or 43 | permanently any contributor for other behaviors that they deem inappropriate, 44 | threatening, offensive, or harmful. 45 | 46 | ## Scope 47 | 48 | This Code of Conduct applies both within project spaces and in public spaces 49 | when an individual is representing the project or its community. Examples of 50 | representing a project or community include using an official project e-mail 51 | address, posting via an official social media account, or acting as an appointed 52 | representative at an online or offline event. Representation of a project may be 53 | further defined and clarified by project maintainers. 54 | 55 | ## Enforcement 56 | 57 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 58 | reported by contacting the project team at contact@process-one.net. All 59 | complaints will be reviewed and investigated and will result in a response that 60 | is deemed necessary and appropriate to the circumstances. The project team is 61 | obligated to maintain confidentiality with regard to the reporter of an incident. 62 | Further details of specific enforcement policies may be posted separately. 63 | 64 | Project maintainers who do not follow or enforce the Code of Conduct in good 65 | faith may face temporary or permanent repercussions as determined by other 66 | members of the project's leadership. 67 | 68 | ## Attribution 69 | 70 | This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, 71 | available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html 72 | 73 | [homepage]: https://www.contributor-covenant.org 74 | 75 | For answers to common questions about this code of conduct, see 76 | https://www.contributor-covenant.org/faq 77 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | We'd love for you to contribute to our source code and to make our project even better than it is 4 | today! Here are the guidelines we'd like you to follow: 5 | 6 | * [Code of Conduct](#coc) 7 | * [Questions and Problems](#question) 8 | * [Issues and Bugs](#issue) 9 | * [Feature Requests](#feature) 10 | * [Issue Submission Guidelines](#submit) 11 | * [Pull Request Submission Guidelines](#submit-pr) 12 | * [Signing the CLA](#cla) 13 | 14 | ## Code of Conduct 15 | 16 | Help us keep our community open-minded and inclusive. Please read and follow our [Code of Conduct][coc]. 17 | 18 | ## Questions, Bugs, Features 19 | 20 | ### Got a Question or Problem? 21 | 22 | Do not open issues for general support questions as we want to keep GitHub issues for bug reports 23 | and feature requests. You've got much better chances of getting your question answered on dedicated 24 | support platforms, the best being [Stack Overflow][stackoverflow]. 25 | 26 | Stack Overflow is a much better place to ask questions since: 27 | 28 | - there are thousands of people willing to help on Stack Overflow 29 | - questions and answers stay available for public viewing so your question / answer might help 30 | someone else 31 | - Stack Overflow's voting system assures that the best answers are prominently visible. 32 | 33 | To save your and our time, we will systematically close all issues that are requests for general 34 | support and redirect people to the section you are reading right now. 35 | 36 | ### Found an Issue or Bug? 37 | 38 | If you find a bug in the source code, you can help us by submitting an issue to our 39 | [GitHub Repository][github]. Even better, you can submit a Pull Request with a fix. 40 | 41 | ### Missing a Feature? 42 | 43 | You can request a new feature by submitting an issue to our [GitHub Repository][github-issues]. 44 | 45 | If you would like to implement a new feature then consider what kind of change it is: 46 | 47 | * **Major Changes** that you wish to contribute to the project should be discussed first in an 48 | [GitHub issue][github-issues] that clearly outlines the changes and benefits of the feature. 49 | * **Small Changes** can directly be crafted and submitted to the [GitHub Repository][github] 50 | as a Pull Request. See the section about [Pull Request Submission Guidelines](#submit-pr). 51 | 52 | ## Issue Submission Guidelines 53 | 54 | Before you submit your issue search the archive, maybe your question was already answered. 55 | 56 | If your issue appears to be a bug, and hasn't been reported, open a new issue. Help us to maximize 57 | the effort we can spend fixing issues and adding new features, by not reporting duplicate issues. 58 | 59 | The "[new issue][github-new-issue]" form contains a number of prompts that you should fill out to 60 | make it easier to understand and categorize the issue. 61 | 62 | ## Pull Request Submission Guidelines 63 | 64 | By submitting a pull request for a code or doc contribution, you need to have the right 65 | to grant your contribution's copyright license to ProcessOne. Please check [ProcessOne CLA][cla] 66 | for details. 67 | 68 | Before you submit your pull request consider the following guidelines: 69 | 70 | * Search [GitHub][github-pr] for an open or closed Pull Request 71 | that relates to your submission. You don't want to duplicate effort. 72 | * Make your changes in a new git branch: 73 | 74 | ```shell 75 | git checkout -b my-fix-branch master 76 | ``` 77 | * Test your changes and, if relevant, expand the automated test suite. 78 | * Create your patch commit, including appropriate test cases. 79 | * If the changes affect public APIs, change or add relevant documentation. 80 | * Commit your changes using a descriptive commit message. 81 | 82 | ```shell 83 | git commit -a 84 | ``` 85 | Note: the optional commit `-a` command line option will automatically "add" and "rm" edited files. 86 | 87 | * Push your branch to GitHub: 88 | 89 | ```shell 90 | git push origin my-fix-branch 91 | ``` 92 | 93 | * In GitHub, send a pull request to `master` branch. This will trigger the continuous integration and run the test. 94 | We will also notify you if you have not yet signed the [contribution agreement][cla]. 95 | 96 | * If you find that the continunous integration has failed, look into the logs to find out 97 | if your changes caused test failures, the commit message was malformed etc. If you find that the 98 | tests failed or times out for unrelated reasons, you can ping a team member so that the build can be 99 | restarted. 100 | 101 | * If we suggest changes, then: 102 | 103 | * Make the required updates. 104 | * Test your changes and test cases. 105 | * Commit your changes to your branch (e.g. `my-fix-branch`). 106 | * Push the changes to your GitHub repository (this will update your Pull Request). 107 | 108 | You can also amend the initial commits and force push them to the branch. 109 | 110 | ```shell 111 | git rebase master -i 112 | git push origin my-fix-branch -f 113 | ``` 114 | 115 | This is generally easier to follow, but separate commits are useful if the Pull Request contains 116 | iterations that might be interesting to see side-by-side. 117 | 118 | That's it! Thank you for your contribution! 119 | 120 | ## Signing the Contributor License Agreement (CLA) 121 | 122 | Upon submitting a Pull Request, we will ask you to sign our CLA if you haven't done 123 | so before. It's a quick process, we promise, and you will be able to do it all online 124 | 125 | You can read [ProcessOne Contribution License Agreement][cla] in PDF. 126 | 127 | This is part of the legal framework of the open-source ecosystem that adds some red tape, 128 | but protects both the contributor and the company / foundation behind the project. It also 129 | gives us the option to relicense the code with a more permissive license in the future. 130 | 131 | 132 | [coc]: https://github.com/processone/p1_utils/blob/master/CODE_OF_CONDUCT.md 133 | [stackoverflow]: https://stackoverflow.com/ 134 | [github]: https://github.com/processone/p1_utils 135 | [github-issues]: https://github.com/processone/p1_utils/issues 136 | [github-new-issue]: https://github.com/processone/p1_utils/issues/new 137 | [github-pr]: https://github.com/processone/p1_utils/pulls 138 | [cla]: https://www.process-one.net/resources/ejabberd-cla.pdf 139 | [license]: https://github.com/processone/p1_utils/blob/master/LICENSE.txt 140 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | 2 | Apache License 3 | Version 2.0, January 2004 4 | http://www.apache.org/licenses/ 5 | 6 | TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 7 | 8 | 1. Definitions. 9 | 10 | "License" shall mean the terms and conditions for use, reproduction, 11 | and distribution as defined by Sections 1 through 9 of this document. 12 | 13 | "Licensor" shall mean the copyright owner or entity authorized by 14 | the copyright owner that is granting the License. 15 | 16 | "Legal Entity" shall mean the union of the acting entity and all 17 | other entities that control, are controlled by, or are under common 18 | control with that entity. For the purposes of this definition, 19 | "control" means (i) the power, direct or indirect, to cause the 20 | direction or management of such entity, whether by contract or 21 | otherwise, or (ii) ownership of fifty percent (50%) or more of the 22 | outstanding shares, or (iii) beneficial ownership of such entity. 23 | 24 | "You" (or "Your") shall mean an individual or Legal Entity 25 | exercising permissions granted by this License. 26 | 27 | "Source" form shall mean the preferred form for making modifications, 28 | including but not limited to software source code, documentation 29 | source, and configuration files. 30 | 31 | "Object" form shall mean any form resulting from mechanical 32 | transformation or translation of a Source form, including but 33 | not limited to compiled object code, generated documentation, 34 | and conversions to other media types. 35 | 36 | "Work" shall mean the work of authorship, whether in Source or 37 | Object form, made available under the License, as indicated by a 38 | copyright notice that is included in or attached to the work 39 | (an example is provided in the Appendix below). 40 | 41 | "Derivative Works" shall mean any work, whether in Source or Object 42 | form, that is based on (or derived from) the Work and for which the 43 | editorial revisions, annotations, elaborations, or other modifications 44 | represent, as a whole, an original work of authorship. For the purposes 45 | of this License, Derivative Works shall not include works that remain 46 | separable from, or merely link (or bind by name) to the interfaces of, 47 | the Work and Derivative Works thereof. 48 | 49 | "Contribution" shall mean any work of authorship, including 50 | the original version of the Work and any modifications or additions 51 | to that Work or Derivative Works thereof, that is intentionally 52 | submitted to Licensor for inclusion in the Work by the copyright owner 53 | or by an individual or Legal Entity authorized to submit on behalf of 54 | the copyright owner. For the purposes of this definition, "submitted" 55 | means any form of electronic, verbal, or written communication sent 56 | to the Licensor or its representatives, including but not limited to 57 | communication on electronic mailing lists, source code control systems, 58 | and issue tracking systems that are managed by, or on behalf of, the 59 | Licensor for the purpose of discussing and improving the Work, but 60 | excluding communication that is conspicuously marked or otherwise 61 | designated in writing by the copyright owner as "Not a Contribution." 62 | 63 | "Contributor" shall mean Licensor and any individual or Legal Entity 64 | on behalf of whom a Contribution has been received by Licensor and 65 | subsequently incorporated within the Work. 66 | 67 | 2. Grant of Copyright License. Subject to the terms and conditions of 68 | this License, each Contributor hereby grants to You a perpetual, 69 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 70 | copyright license to reproduce, prepare Derivative Works of, 71 | publicly display, publicly perform, sublicense, and distribute the 72 | Work and such Derivative Works in Source or Object form. 73 | 74 | 3. Grant of Patent License. Subject to the terms and conditions of 75 | this License, each Contributor hereby grants to You a perpetual, 76 | worldwide, non-exclusive, no-charge, royalty-free, irrevocable 77 | (except as stated in this section) patent license to make, have made, 78 | use, offer to sell, sell, import, and otherwise transfer the Work, 79 | where such license applies only to those patent claims licensable 80 | by such Contributor that are necessarily infringed by their 81 | Contribution(s) alone or by combination of their Contribution(s) 82 | with the Work to which such Contribution(s) was submitted. If You 83 | institute patent litigation against any entity (including a 84 | cross-claim or counterclaim in a lawsuit) alleging that the Work 85 | or a Contribution incorporated within the Work constitutes direct 86 | or contributory patent infringement, then any patent licenses 87 | granted to You under this License for that Work shall terminate 88 | as of the date such litigation is filed. 89 | 90 | 4. Redistribution. You may reproduce and distribute copies of the 91 | Work or Derivative Works thereof in any medium, with or without 92 | modifications, and in Source or Object form, provided that You 93 | meet the following conditions: 94 | 95 | (a) You must give any other recipients of the Work or 96 | Derivative Works a copy of this License; and 97 | 98 | (b) You must cause any modified files to carry prominent notices 99 | stating that You changed the files; and 100 | 101 | (c) You must retain, in the Source form of any Derivative Works 102 | that You distribute, all copyright, patent, trademark, and 103 | attribution notices from the Source form of the Work, 104 | excluding those notices that do not pertain to any part of 105 | the Derivative Works; and 106 | 107 | (d) If the Work includes a "NOTICE" text file as part of its 108 | distribution, then any Derivative Works that You distribute must 109 | include a readable copy of the attribution notices contained 110 | within such NOTICE file, excluding those notices that do not 111 | pertain to any part of the Derivative Works, in at least one 112 | of the following places: within a NOTICE text file distributed 113 | as part of the Derivative Works; within the Source form or 114 | documentation, if provided along with the Derivative Works; or, 115 | within a display generated by the Derivative Works, if and 116 | wherever such third-party notices normally appear. The contents 117 | of the NOTICE file are for informational purposes only and 118 | do not modify the License. You may add Your own attribution 119 | notices within Derivative Works that You distribute, alongside 120 | or as an addendum to the NOTICE text from the Work, provided 121 | that such additional attribution notices cannot be construed 122 | as modifying the License. 123 | 124 | You may add Your own copyright statement to Your modifications and 125 | may provide additional or different license terms and conditions 126 | for use, reproduction, or distribution of Your modifications, or 127 | for any such Derivative Works as a whole, provided Your use, 128 | reproduction, and distribution of the Work otherwise complies with 129 | the conditions stated in this License. 130 | 131 | 5. Submission of Contributions. Unless You explicitly state otherwise, 132 | any Contribution intentionally submitted for inclusion in the Work 133 | by You to the Licensor shall be under the terms and conditions of 134 | this License, without any additional terms or conditions. 135 | Notwithstanding the above, nothing herein shall supersede or modify 136 | the terms of any separate license agreement you may have executed 137 | with Licensor regarding such Contributions. 138 | 139 | 6. Trademarks. This License does not grant permission to use the trade 140 | names, trademarks, service marks, or product names of the Licensor, 141 | except as required for reasonable and customary use in describing the 142 | origin of the Work and reproducing the content of the NOTICE file. 143 | 144 | 7. Disclaimer of Warranty. Unless required by applicable law or 145 | agreed to in writing, Licensor provides the Work (and each 146 | Contributor provides its Contributions) on an "AS IS" BASIS, 147 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or 148 | implied, including, without limitation, any warranties or conditions 149 | of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A 150 | PARTICULAR PURPOSE. You are solely responsible for determining the 151 | appropriateness of using or redistributing the Work and assume any 152 | risks associated with Your exercise of permissions under this License. 153 | 154 | 8. Limitation of Liability. In no event and under no legal theory, 155 | whether in tort (including negligence), contract, or otherwise, 156 | unless required by applicable law (such as deliberate and grossly 157 | negligent acts) or agreed to in writing, shall any Contributor be 158 | liable to You for damages, including any direct, indirect, special, 159 | incidental, or consequential damages of any character arising as a 160 | result of this License or out of the use or inability to use the 161 | Work (including but not limited to damages for loss of goodwill, 162 | work stoppage, computer failure or malfunction, or any and all 163 | other commercial damages or losses), even if such Contributor 164 | has been advised of the possibility of such damages. 165 | 166 | 9. Accepting Warranty or Additional Liability. While redistributing 167 | the Work or Derivative Works thereof, You may choose to offer, 168 | and charge a fee for, acceptance of support, warranty, indemnity, 169 | or other liability obligations and/or rights consistent with this 170 | License. However, in accepting such obligations, You may act only 171 | on Your own behalf and on Your sole responsibility, not on behalf 172 | of any other Contributor, and only if You agree to indemnify, 173 | defend, and hold each Contributor harmless for any liability 174 | incurred by, or claims asserted against, such Contributor by reason 175 | of your accepting any such warranty or additional liability. 176 | 177 | END OF TERMS AND CONDITIONS 178 | 179 | APPENDIX: How to apply the Apache License to your work. 180 | 181 | To apply the Apache License to your work, attach the following 182 | boilerplate notice, with the fields enclosed by brackets "[]" 183 | replaced with your own identifying information. (Don't include 184 | the brackets!) The text should be enclosed in the appropriate 185 | comment syntax for the file format. We also recommend that a 186 | file or class name and description of purpose be included on the 187 | same "printed page" as the copyright notice for easier 188 | identification within third-party archives. 189 | 190 | Copyright [yyyy] [name of copyright owner] 191 | 192 | Licensed under the Apache License, Version 2.0 (the "License"); 193 | you may not use this file except in compliance with the License. 194 | You may obtain a copy of the License at 195 | 196 | http://www.apache.org/licenses/LICENSE-2.0 197 | 198 | Unless required by applicable law or agreed to in writing, software 199 | distributed under the License is distributed on an "AS IS" BASIS, 200 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 201 | See the License for the specific language governing permissions and 202 | limitations under the License. 203 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | REBAR ?= rebar 2 | 3 | IS_REBAR3:=$(shell expr `$(REBAR) --version | awk -F '[ .]' '/rebar / {print $$2}'` '>=' 3) 4 | 5 | all: src 6 | 7 | src: 8 | $(REBAR) compile 9 | 10 | clean: 11 | $(REBAR) clean 12 | 13 | ifeq "$(IS_REBAR3)" "1" 14 | test: 15 | $(REBAR) eunit -v 16 | else 17 | test: all 18 | $(REBAR) -v skip_deps=true eunit 19 | endif 20 | 21 | ifeq "$(IS_REBAR3)" "1" 22 | dialyzer: 23 | $(REBAR) dialyzer 24 | else 25 | dialyzer/erlang.plt: 26 | @mkdir -p dialyzer 27 | @dialyzer --build_plt --output_plt dialyzer/erlang.plt \ 28 | -o dialyzer/erlang.log --apps kernel stdlib erts inets crypto compiler edoc tools syntax_tools xmerl; \ 29 | status=$$? ; if [ $$status -ne 2 ]; then exit $$status; else exit 0; fi 30 | 31 | dialyzer/p1_utils.plt: 32 | @mkdir -p dialyzer 33 | @dialyzer --build_plt --output_plt dialyzer/p1_utils.plt \ 34 | -o dialyzer/p1_utils.log ebin; \ 35 | status=$$? ; if [ $$status -ne 2 ]; then exit $$status; else exit 0; fi 36 | 37 | erlang_plt: dialyzer/erlang.plt 38 | @dialyzer --plt dialyzer/erlang.plt --check_plt -o dialyzer/erlang.log; \ 39 | status=$$? ; if [ $$status -ne 2 ]; then exit $$status; else exit 0; fi 40 | 41 | p1_utils_plt: dialyzer/p1_utils.plt 42 | @dialyzer --plt dialyzer/p1_utils.plt --check_plt -o dialyzer/p1_utils.log; \ 43 | status=$$? ; if [ $$status -ne 2 ]; then exit $$status; else exit 0; fi 44 | 45 | dialyzer: erlang_plt p1_utils_plt 46 | @dialyzer --plts dialyzer/*.plt --no_check_plt \ 47 | --get_warnings -o dialyzer/error.log ebin; \ 48 | status=$$? ; if [ $$status -ne 2 ]; then exit $$status; else exit 0; fi 49 | endif 50 | 51 | .PHONY: clean src test dialyzer erlang_plt p1_utils_plt 52 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # p1_utils 2 | 3 | [![CI](https://github.com/processone/p1_utils/actions/workflows/ci.yml/badge.svg?branch=master)](https://github.com/processone/p1_utils/actions/workflows/ci.yml) 4 | [![Coverage Status](https://coveralls.io/repos/processone/p1_utils/badge.svg?branch=master&service=github)](https://coveralls.io/github/processone/p1_utils?branch=master) 5 | [![Hex version](https://img.shields.io/hexpm/v/p1_utils.svg "Hex version")](https://hex.pm/packages/p1_utils) 6 | 7 | p1_utils is an application containing ProcessOne modules and tools that are leveraged in other development projects: 8 | 9 | * `p1_fsm` and `p1_server` are drop-in replacements of Erlang gen_fsm and gen_server, offering extra option for better 10 | reliability in production. They support mostly priority messages and message queue length controls. 11 | * `p1_nif_utils` is an helper utilities for handling NIF code. 12 | * `treap` is a treap algorithm implementation. It is a randomized binary search tree. See: https://en.wikipedia.org/wiki/Treap 13 | * `p1_time_compat` is a module to ease support and migration of Erlang 14 | time management function from Erlang R16/R17 to Erlang R18. 15 | * `p1_http` is an http client which provides a common API for inets / lhttpc / ibrowse 16 | * `p1_proxy_protocol` decodes HAproxy protocol (v1 and v2) headers. 17 | 18 | If you have `rebar` binary, you can generate `p1_utils` documentation by running `rebar3 edoc`. 19 | -------------------------------------------------------------------------------- /include/p1_queue.hrl: -------------------------------------------------------------------------------- 1 | -record(file_q, 2 | {tail = 0 :: non_neg_integer(), 3 | head = 0 :: non_neg_integer(), 4 | limit :: non_neg_integer() | unlimited, 5 | fd :: file:fd(), 6 | path :: binary(), 7 | owner = self() :: pid(), 8 | start = 0 :: non_neg_integer(), 9 | stop = 0 :: non_neg_integer()}). 10 | 11 | -define(qlen(Q), element(2, Q)). 12 | -------------------------------------------------------------------------------- /rebar.config: -------------------------------------------------------------------------------- 1 | {erl_opts, [ 2 | debug_info, 3 | {platform_define, "^(R|1|20|21)", 'USE_OLD_SYS_GET_DEBUG'}, 4 | {platform_define, "^(15|16|17)", 'NEED_TIME_FALLBACKS'}, 5 | {platform_define, "^(18|19|([2-9][0-9]))", 'HAVE_RAND'} 6 | ]}. 7 | 8 | {cover_enabled, true}. 9 | {cover_export_enabled, true}. 10 | {coveralls_coverdata , "_build/test/cover/eunit.coverdata"}. 11 | {coveralls_service_name , "github"}. 12 | 13 | {xref_checks, [undefined_function_calls, undefined_functions, deprecated_function_calls, deprecated_functions]}. 14 | 15 | %% Local Variables: 16 | %% mode: erlang 17 | %% End: 18 | %% vim: set filetype=erlang tabstop=8: 19 | -------------------------------------------------------------------------------- /rebar.config.script: -------------------------------------------------------------------------------- 1 | %%%---------------------------------------------------------------------- 2 | %%% File : rebar.config.script 3 | %%% Author : Mickael Remond 4 | %%% Purpose : Rebar build script. Compliant with rebar and rebar3. 5 | %%% Created : 24 Nov 2015 by Mickael Remond 6 | %%% 7 | %%% Copyright (C) 2002-2025 ProcessOne, SARL. All Rights Reserved. 8 | %%% 9 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 10 | %%% you may not use this file except in compliance with the License. 11 | %%% You may obtain a copy of the License at 12 | %%% 13 | %%% http://www.apache.org/licenses/LICENSE-2.0 14 | %%% 15 | %%% Unless required by applicable law or agreed to in writing, software 16 | %%% distributed under the License is distributed on an "AS IS" BASIS, 17 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 18 | %%% See the License for the specific language governing permissions and 19 | %%% limitations under the License. 20 | %%% 21 | %%%---------------------------------------------------------------------- 22 | SysVersion = lists:map(fun erlang:list_to_integer/1, 23 | string:tokens(erlang:system_info(version), ".")), 24 | 25 | IsRebar3 = case application:get_key(rebar, vsn) of 26 | {ok, VSN} -> 27 | [VSN1 | _] = string:tokens(VSN, "-"), 28 | [Maj|_] = string:tokens(VSN1, "."), 29 | (list_to_integer(Maj) >= 3); 30 | undefined -> 31 | lists:keymember(mix, 1, application:loaded_applications()) 32 | end, 33 | 34 | ModCfg0 = fun(F, Cfg, [Key|Tail], Op, Default) -> 35 | {OldVal,PartCfg} = case lists:keytake(Key, 1, Cfg) of 36 | {value, {_, V1}, V2} -> {V1, V2}; 37 | false -> {if Tail == [] -> Default; true -> [] end, Cfg} 38 | end, 39 | case Tail of 40 | [] -> 41 | [{Key, Op(OldVal)} | PartCfg]; 42 | _ -> 43 | [{Key, F(F, OldVal, Tail, Op, Default)} | PartCfg] 44 | end 45 | end, 46 | ModCfg = fun(Cfg, Keys, Op, Default) -> ModCfg0(ModCfg0, Cfg, Keys, Op, 47 | Default) end, 48 | 49 | ModCfgS = fun(Cfg, Keys, Val) -> ModCfg0(ModCfg0, Cfg, Keys, fun(_V) -> 50 | Val end, "") end, 51 | 52 | 53 | FilterConfig = fun(F, Cfg, [{Path, true, ModFun, Default} | Tail]) -> 54 | F(F, ModCfg0(ModCfg0, Cfg, Path, ModFun, Default), Tail); 55 | (F, Cfg, [_ | Tail]) -> 56 | F(F, Cfg, Tail); 57 | (F, Cfg, []) -> 58 | Cfg 59 | end, 60 | 61 | AppendStr = fun(Append) -> 62 | fun("") -> 63 | Append; 64 | (Val) -> 65 | Val ++ " " ++ Append 66 | end 67 | end, 68 | AppendList = fun(Append) -> 69 | fun(Val) -> 70 | Val ++ Append 71 | end 72 | end, 73 | 74 | Rebar3DepsFilter = fun(DepsList) -> 75 | lists:map(fun({DepName,_, {git,_, {tag,Version}}}) -> 76 | {DepName, Version}; 77 | (Dep) -> 78 | Dep 79 | end, DepsList) 80 | end, 81 | 82 | GlobalDepsFilter = fun(Deps) -> 83 | DepNames = lists:map(fun({DepName, _, _}) -> DepName; 84 | ({DepName, _}) -> DepName 85 | end, Deps), 86 | lists:filtermap(fun(Dep) -> 87 | case code:lib_dir(Dep) of 88 | {error, _} -> 89 | {true,"Unable to locate dep '"++atom_to_list(Dep)++"' in system deps."}; 90 | _ -> 91 | false 92 | end 93 | end, DepNames) 94 | end, 95 | 96 | GithubConfig = case {os:getenv("GITHUB_ACTIONS"), os:getenv("GITHUB_TOKEN")} of 97 | {"true", Token} when is_list(Token) -> 98 | CONFIG1 = [{coveralls_repo_token, Token}, 99 | {coveralls_service_job_id, os:getenv("GITHUB_RUN_ID")}, 100 | {coveralls_commit_sha, os:getenv("GITHUB_SHA")}, 101 | {coveralls_service_number, os:getenv("GITHUB_RUN_NUMBER")}], 102 | case os:getenv("GITHUB_EVENT_NAME") =:= "pull_request" 103 | andalso string:tokens(os:getenv("GITHUB_REF"), "/") of 104 | [_, "pull", PRNO, _] -> 105 | [{coveralls_service_pull_request, PRNO} | CONFIG1]; 106 | _ -> 107 | CONFIG1 108 | end; 109 | _ -> 110 | [] 111 | end, 112 | 113 | Rules = [ 114 | {[deps], IsRebar3, 115 | Rebar3DepsFilter, []}, 116 | {[plugins], IsRebar3, 117 | AppendList([pc]), []}, 118 | {[plugins], os:getenv("COVERALLS") == "true", 119 | AppendList([{coveralls, {git, 120 | "https://github.com/processone/coveralls-erl.git", 121 | {branch, "addjsonfile"}}} ]), []}, 122 | {[deps], os:getenv("USE_GLOBAL_DEPS") /= false, 123 | GlobalDepsFilter, []} 124 | ], 125 | 126 | 127 | Config = FilterConfig(FilterConfig, CONFIG, Rules) ++ GithubConfig, 128 | 129 | %io:format("Rules:~n~p~n~nCONFIG:~n~p~n~nConfig:~n~p~n", [Rules, CONFIG, Config]), 130 | 131 | Config. 132 | 133 | %% Local Variables: 134 | %% mode: erlang 135 | %% End: 136 | %% vim: set filetype=erlang tabstop=8: 137 | -------------------------------------------------------------------------------- /rebar.lock: -------------------------------------------------------------------------------- 1 | []. 2 | -------------------------------------------------------------------------------- /src/p1_file_queue.erl: -------------------------------------------------------------------------------- 1 | %%%------------------------------------------------------------------- 2 | %%% @author Evgeny Khramtsov 3 | %%% @copyright (C) 2017-2025 Evgeny Khramtsov 4 | %%% @doc 5 | %%% 6 | %%% @end 7 | %%% Created : 8 Mar 2017 by Evgeny Khramtsov 8 | %%%------------------------------------------------------------------- 9 | -module(p1_file_queue). 10 | 11 | -behaviour(p1_server). 12 | 13 | %% API 14 | -export([new/1, is_queue/1, len/1, is_empty/1, get_limit/1, set_limit/2, 15 | in/2, out/1, peek/1, drop/1, from_list/2, to_list/1, foreach/2, 16 | foldl/3, dropwhile/2, path/1, clear/1, format_error/1]). 17 | -export([init/1, handle_call/3, handle_cast/2, handle_info/2, 18 | terminate/2, code_change/3]). 19 | -export([start/1, stop/0, start_link/1]). 20 | %% For tests only 21 | -export([close/1]). 22 | 23 | -include("p1_queue.hrl"). 24 | 25 | -record(state, {dir :: file:filename(), 26 | counter :: non_neg_integer(), 27 | files :: map()}). 28 | 29 | -type error_reason() :: {corrupted | not_owner | file:posix(), binary()}. 30 | -type queue() :: #file_q{}. 31 | -export_type([queue/0, error_reason/0]). 32 | 33 | -define(MAX_QUEUES_PER_PROCESS, 10). 34 | 35 | %%%=================================================================== 36 | %%% API 37 | %%%=================================================================== 38 | new(Limit) -> 39 | case get_filename() of 40 | {ok, Path} -> 41 | case file:open(Path, [read, write, binary, raw]) of 42 | {ok, Fd} -> 43 | monitor_me(Path), 44 | clear(#file_q{fd = Fd, path = Path, limit = Limit}); 45 | {error, Err} -> 46 | erlang:error({bad_queue, {Err, Path}}) 47 | end; 48 | {error, Err} -> 49 | erlang:error(Err) 50 | end. 51 | 52 | path(#file_q{path = Path}) -> 53 | Path. 54 | 55 | is_queue(#file_q{}) -> true; 56 | is_queue(_) -> false. 57 | 58 | len(#file_q{tail = Tail}) -> 59 | Tail. 60 | 61 | is_empty(#file_q{tail = Tail}) -> 62 | Tail == 0. 63 | 64 | get_limit(#file_q{limit = Limit}) -> 65 | Limit. 66 | 67 | set_limit(Q, Limit) -> 68 | Q#file_q{limit = Limit}. 69 | 70 | %% 71 | %% This is the only operation with side-effects, thus if you call 72 | %% this function on a queue and get the new queue as a result, 73 | %% you *MUST NOT* use the original queue, e.g. the following 74 | %% is potientailly dangerous: 75 | %% Q2 = p1_queue:in(some, Q1), 76 | %% p1_queue:out(Q1) 77 | %% ... likely an exception occurs here ... 78 | %% 79 | in(_, #file_q{owner = Owner, path = Path}) when Owner /= self() -> 80 | erlang:error({bad_queue, {not_owner, Path}}); 81 | in(Item, #file_q{start = Pos, stop = Pos} = Q) when Pos /= 0 -> 82 | in(Item, clear(Q)); 83 | in(Item, #file_q{fd = Fd, tail = Tail, stop = Pos, limit = Limit} = Q) 84 | when Tail < Limit -> 85 | Data = term_to_binary(Item), 86 | Size = size(Data), 87 | case file:pwrite(Fd, Pos, <>) of 88 | ok -> 89 | gc(Q#file_q{tail = Tail + 1, stop = Pos + Size + 4}); 90 | {error, Err} -> 91 | erlang:error({bad_queue, {Err, Q#file_q.path}}) 92 | end; 93 | in(_, _) -> 94 | erlang:error(full). 95 | 96 | out(#file_q{tail = 0} = Q) -> 97 | {empty, Q}; 98 | out(#file_q{owner = Owner, path = Path}) when Owner /= self() -> 99 | erlang:error({bad_queue, {not_owner, Path}}); 100 | out(#file_q{fd = Fd, tail = Tail, head = Head, start = Pos} = Q) -> 101 | case read_item(Fd, Pos) of 102 | {ok, Item, Next} -> 103 | {{value, Item}, 104 | Q#file_q{tail = Tail - 1, head = Head + 1, start = Next}}; 105 | {error, Err} -> 106 | erlang:error({bad_queue, {Err, Q#file_q.path}}) 107 | end. 108 | 109 | peek(#file_q{tail = 0}) -> 110 | empty; 111 | peek(#file_q{owner = Owner, path = Path}) when Owner /= self() -> 112 | erlang:error({bad_queue, {not_owner, Path}}); 113 | peek(#file_q{fd = Fd, start = Pos} = Q) -> 114 | case read_item(Fd, Pos) of 115 | {ok, Item, _} -> 116 | {value, Item}; 117 | {error, Err} -> 118 | erlang:error({bad_queue, {Err, Q#file_q.path}}) 119 | end. 120 | 121 | drop(#file_q{tail = 0}) -> 122 | erlang:error(empty); 123 | drop(#file_q{owner = Owner, path = Path}) when Owner /= self() -> 124 | erlang:error({bad_queue, {not_owner, Path}}); 125 | drop(#file_q{fd = Fd, start = Pos, tail = Tail, head = Head} = Q) -> 126 | case read_item_size(Fd, Pos) of 127 | {ok, Size} -> 128 | Q#file_q{tail = Tail - 1, head = Head + 1, start = Pos + Size + 4}; 129 | {error, Err} -> 130 | erlang:error({bad_queue, {Err, Q#file_q.path}}) 131 | end. 132 | 133 | from_list(Items, Limit) when length(Items) =< Limit -> 134 | lists:foldl(fun in/2, new(Limit), Items); 135 | from_list(_, _) -> 136 | erlang:error(full). 137 | 138 | to_list(#file_q{owner = Owner, path = Path}) when Owner /= self() -> 139 | erlang:error({bad_queue, {not_owner, Path}}); 140 | to_list(#file_q{fd = Fd, tail = Tail, start = Pos} = Q) -> 141 | case to_list(Fd, Pos, Tail, []) of 142 | {ok, L} -> L; 143 | {error, Err} -> erlang:error({bad_queue, {Err, Q#file_q.path}}) 144 | end. 145 | 146 | dropwhile(F, Q) -> 147 | case peek(Q) of 148 | {value, Item} -> 149 | case F(Item) of 150 | true -> 151 | dropwhile(F, drop(Q)); 152 | _ -> 153 | Q 154 | end; 155 | empty -> 156 | Q 157 | end. 158 | 159 | foldl(F, Acc, Q) -> 160 | case out(Q) of 161 | {{value, Item}, Q1} -> 162 | Acc1 = F(Item, Acc), 163 | foldl(F, Acc1, Q1); 164 | {empty, _} -> 165 | Acc 166 | end. 167 | 168 | foreach(F, Q) -> 169 | case out(Q) of 170 | {{value, Item}, Q1} -> 171 | F(Item), 172 | foreach(F, Q1); 173 | {empty, _} -> 174 | ok 175 | end. 176 | 177 | clear(#file_q{owner = Owner, path = Path}) when Owner /= self() -> 178 | erlang:error({bad_queue, {not_owner, Path}}); 179 | clear(#file_q{fd = Fd, path = Path, limit = Limit}) -> 180 | case file:position(Fd, 0) of 181 | {ok, 0} -> 182 | case file:truncate(Fd) of 183 | ok -> 184 | #file_q{fd = Fd, path = Path, limit = Limit}; 185 | {error, Err} -> 186 | erlang:error({bad_queue, {Err, Path}}) 187 | end; 188 | {error, Err} -> 189 | erlang:error({bad_queue, {Err, Path}}) 190 | end. 191 | 192 | close(#file_q{fd = Fd, path = Path}) -> 193 | file:close(Fd), 194 | demonitor_me(Path). 195 | 196 | -spec format_error(error_reason()) -> string(). 197 | format_error({corrupted, Path}) -> 198 | "file queue is corrupted (" ++ binary_to_list(Path) ++ ")"; 199 | format_error({not_owner, Path}) -> 200 | "not a file queue owner (" ++ binary_to_list(Path) ++ ")"; 201 | format_error({Posix, Path}) -> 202 | case file:format_error(Posix) of 203 | "unknown POSIX error" -> % Erlang/OTP 25 and older 204 | atom_to_list(Posix) ++ " (" ++ binary_to_list(Path) ++ ")"; 205 | [$u, $n, $k, $n, $o, $w, $n | _] -> % Erlang/OTP 26 and newer 206 | atom_to_list(Posix) ++ " (" ++ binary_to_list(Path) ++ ")"; 207 | Reason -> 208 | Reason ++ " (" ++ binary_to_list(Path) ++ ")" 209 | end. 210 | 211 | %%%=================================================================== 212 | %%% p1_server API 213 | %%%=================================================================== 214 | start(Dir) -> 215 | Spec = {?MODULE, {?MODULE, start_link, [Dir]}, 216 | permanent, 5000, worker, [?MODULE]}, 217 | supervisor:start_child(p1_utils_sup, Spec). 218 | 219 | stop() -> 220 | supervisor:terminate_child(p1_utils_sup, ?MODULE), 221 | supervisor:delete_child(p1_utils_sup, ?MODULE). 222 | 223 | start_link(Dir) -> 224 | gen_server:start_link({local, ?MODULE}, ?MODULE, [Dir], []). 225 | 226 | init([Dir]) -> 227 | case filelib:ensure_dir(filename:join(Dir, "foo")) of 228 | ok -> 229 | application:start(crypto), 230 | process_flag(trap_exit, true), 231 | {ok, #state{dir = Dir, files = #{}, counter = 0}}; 232 | {error, Reason} -> 233 | error_logger:error_msg( 234 | "failed to create directory \"~s\": ~s", 235 | [Dir, file:format_error(Reason)]), 236 | {stop, Reason} 237 | end. 238 | 239 | handle_call({get_filename, Owner}, _, #state{dir = Dir} = State) -> 240 | Paths = maps:get(Owner, State#state.files, []), 241 | if length(Paths) >= ?MAX_QUEUES_PER_PROCESS -> 242 | {reply, {error, emfile}, State}; 243 | true -> 244 | Counter = State#state.counter + 1, 245 | Path = iolist_to_binary(filename:join(Dir, integer_to_list(Counter))), 246 | {reply, {ok, Path}, State#state{counter = Counter}} 247 | end; 248 | handle_call(_Request, _From, State) -> 249 | Reply = ok, 250 | {reply, Reply, State}. 251 | 252 | handle_cast({monitor, Owner, Path}, State) -> 253 | Paths = maps:get(Owner, State#state.files, []), 254 | if Paths == [] -> erlang:monitor(process, Owner); 255 | true -> ok 256 | end, 257 | Files = maps:put(Owner, [Path|Paths], State#state.files), 258 | {noreply, State#state{files = Files}}; 259 | handle_cast({demonitor, Owner, Path}, State) -> 260 | spawn(fun() -> file:delete(Path) end), 261 | Paths = maps:get(Owner, State#state.files, []), 262 | Files = case lists:delete(Path, Paths) of 263 | [] -> 264 | %% TODO: demonitor process 265 | maps:remove(Owner, State#state.files); 266 | NewPaths -> 267 | maps:put(Owner, NewPaths, State#state.files) 268 | end, 269 | {noreply, State#state{files = Files}}; 270 | handle_cast(_Msg, State) -> 271 | {noreply, State}. 272 | 273 | handle_info({'DOWN', _MRef, _Type, Owner, _Info}, State) -> 274 | Paths = maps:get(Owner, State#state.files, []), 275 | spawn(lists, foreach, 276 | [fun(Path) -> 277 | file:delete(Path) 278 | end, Paths]), 279 | Files = maps:remove(Owner, State#state.files), 280 | {noreply, State#state{files = Files}}; 281 | handle_info(Info, State) -> 282 | error_logger:error_msg("unexpected info: ~p", [Info]), 283 | {noreply, State}. 284 | 285 | terminate(_Reason, #state{dir = Dir}) -> 286 | clean_dir(Dir). 287 | 288 | code_change(_OldVsn, State, _Extra) -> 289 | {ok, State}. 290 | 291 | %%%=================================================================== 292 | %%% Internal functions 293 | %%%=================================================================== 294 | get_filename() -> 295 | p1_server:call(?MODULE, {get_filename, self()}). 296 | 297 | clean_dir(Dir) -> 298 | filelib:fold_files( 299 | Dir, "[0-9]+", false, 300 | fun(File, _) -> file:delete(File) end, 301 | ok). 302 | 303 | monitor_me(Path) -> 304 | p1_server:cast(?MODULE, {monitor, self(), Path}). 305 | 306 | demonitor_me(Path) -> 307 | p1_server:cast(?MODULE, {demonitor, self(), Path}). 308 | 309 | read_item_size(Fd, Pos) -> 310 | case file:pread(Fd, Pos, 4) of 311 | {ok, <>} -> 312 | {ok, Size}; 313 | {error, _} = Err -> 314 | Err; 315 | _ -> 316 | {error, corrupted} 317 | end. 318 | 319 | read_item(Fd, Pos) -> 320 | case read_item_size(Fd, Pos) of 321 | {ok, Size} -> 322 | case file:pread(Fd, Pos+4, Size) of 323 | {ok, Data} -> 324 | try binary_to_term(Data) of 325 | Item -> {ok, Item, Pos + Size + 4} 326 | catch _:_ -> 327 | {error, corrupted} 328 | end; 329 | {error, _} = Err -> 330 | Err; 331 | _ -> 332 | {error, corrupted} 333 | end; 334 | {error, _} = Err -> 335 | Err 336 | end. 337 | 338 | to_list(_Fd, _Pos, 0, Items) -> 339 | {ok, lists:reverse(Items)}; 340 | to_list(Fd, Pos, Len, Items) -> 341 | case read_item(Fd, Pos) of 342 | {ok, Item, NextPos} -> 343 | to_list(Fd, NextPos, Len-1, [Item|Items]); 344 | {error, _} = Err -> 345 | Err 346 | end. 347 | 348 | -define(MAX_HEAD, 1000). 349 | %% @doc shrink head when there are more than MAX_HEAD elements in the head 350 | gc(#file_q{fd = Fd, path = Path, limit = Limit, 351 | tail = Tail, head = Head, 352 | start = Start, stop = Stop} = Q) -> 353 | if Head >= ?MAX_HEAD, Stop > Start -> 354 | try 355 | {ok, NewFd} = file:open(Path, [read, write, raw, binary]), 356 | {ok, _} = file:position(Fd, Start), 357 | {ok, _} = file:copy(Fd, NewFd, Stop - Start), 358 | file:close(Fd), 359 | {ok, _} = file:position(NewFd, Stop - Start), 360 | ok = file:truncate(NewFd), 361 | #file_q{fd = NewFd, start = 0, stop = Stop - Start, 362 | head = 0, tail = Tail, path = Path, limit = Limit} 363 | catch _:{badmatch, {error, Err}} -> 364 | erlang:error({bad_queue, {Err, Path}}); 365 | _:{badmatch, eof} -> 366 | erlang:error({bad_queue, {corrupted, Path}}) 367 | end; 368 | true -> 369 | Q 370 | end. 371 | -------------------------------------------------------------------------------- /src/p1_fsm.erl: -------------------------------------------------------------------------------- 1 | %% ``The contents of this file are subject to the Erlang Public License, 2 | %% Version 1.1, (the "License"); you may not use this file except in 3 | %% compliance with the License. You should have received a copy of the 4 | %% Erlang Public License along with this software. If not, it can be 5 | %% retrieved via the world wide web at http://www.erlang.org/. 6 | %% 7 | %% Software distributed under the License is distributed on an "AS IS" 8 | %% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 9 | %% the License for the specific language governing rights and limitations 10 | %% under the License. 11 | %% 12 | %% The Initial Developer of the Original Code is Ericsson Utvecklings AB. 13 | %% Portions created by Ericsson are Copyright 1999, Ericsson Utvecklings 14 | %% AB. All Rights Reserved.'' 15 | %% 16 | %% The code has been modified and improved by ProcessOne. 17 | %% 18 | %% Copyright 2007-2025 ProcessOne 19 | %% 20 | %% The change adds the following features: 21 | %% - You can send exit(priority_shutdown) to the p1_fsm process to 22 | %% terminate immediatetly. If the fsm trap_exit process flag has been 23 | %% set to true, the FSM terminate function will called. 24 | %% - You can pass the gen_fsm options to control resource usage. 25 | %% {max_queue, N} will exit the process with priority_shutdown 26 | %% - You can limit the time processing a message (TODO): If the 27 | %% message processing does not return in a given period of time, the 28 | %% process will be terminated. 29 | %% - You might customize the State data before sending it to error_logger 30 | %% in case of a crash (just export the function print_state/1) 31 | %% $Id$ 32 | %% 33 | -module(p1_fsm). 34 | 35 | %%%----------------------------------------------------------------- 36 | %%% 37 | %%% This state machine is somewhat more pure than state_lib. It is 38 | %%% still based on State dispatching (one function per state), but 39 | %%% allows a function handle_event to take care of events in all states. 40 | %%% It's not that pure anymore :( We also allow synchronized event sending. 41 | %%% 42 | %%% If the Parent process terminates the Module:terminate/2 43 | %%% function is called. 44 | %%% 45 | %%% The user module should export: 46 | %%% 47 | %%% init(Args) 48 | %%% ==> {ok, StateName, StateData} 49 | %%% {ok, StateName, StateData, Timeout} 50 | %%% ignore 51 | %%% {stop, Reason} 52 | %%% 53 | %%% StateName(Msg, StateData) 54 | %%% 55 | %%% ==> {next_state, NewStateName, NewStateData} 56 | %%% {next_state, NewStateName, NewStateData, Timeout} 57 | %%% {stop, Reason, NewStateData} 58 | %%% Reason = normal | shutdown | Term terminate(State) is called 59 | %%% 60 | %%% StateName(Msg, From, StateData) 61 | %%% 62 | %%% ==> {next_state, NewStateName, NewStateData} 63 | %%% {next_state, NewStateName, NewStateData, Timeout} 64 | %%% {reply, Reply, NewStateName, NewStateData} 65 | %%% {reply, Reply, NewStateName, NewStateData, Timeout} 66 | %%% {stop, Reason, NewStateData} 67 | %%% Reason = normal | shutdown | Term terminate(State) is called 68 | %%% 69 | %%% handle_event(Msg, StateName, StateData) 70 | %%% 71 | %%% ==> {next_state, NewStateName, NewStateData} 72 | %%% {next_state, NewStateName, NewStateData, Timeout} 73 | %%% {stop, Reason, Reply, NewStateData} 74 | %%% {stop, Reason, NewStateData} 75 | %%% Reason = normal | shutdown | Term terminate(State) is called 76 | %%% 77 | %%% handle_sync_event(Msg, From, StateName, StateData) 78 | %%% 79 | %%% ==> {next_state, NewStateName, NewStateData} 80 | %%% {next_state, NewStateName, NewStateData, Timeout} 81 | %%% {reply, Reply, NewStateName, NewStateData} 82 | %%% {reply, Reply, NewStateName, NewStateData, Timeout} 83 | %%% {stop, Reason, Reply, NewStateData} 84 | %%% {stop, Reason, NewStateData} 85 | %%% Reason = normal | shutdown | Term terminate(State) is called 86 | %%% 87 | %%% handle_info(Info, StateName) (e.g. {'EXIT', P, R}, {nodedown, N}, ... 88 | %%% 89 | %%% ==> {next_state, NewStateName, NewStateData} 90 | %%% {next_state, NewStateName, NewStateData, Timeout} 91 | %%% {stop, Reason, NewStateData} 92 | %%% Reason = normal | shutdown | Term terminate(State) is called 93 | %%% 94 | %%% terminate(Reason, StateName, StateData) Let the user module clean up 95 | %%% always called when server terminates 96 | %%% 97 | %%% ==> the return value is ignored 98 | %%% 99 | %%% 100 | %%% The work flow (of the fsm) can be described as follows: 101 | %%% 102 | %%% User module fsm 103 | %%% ----------- ------- 104 | %%% start -----> start 105 | %%% init <----- . 106 | %%% 107 | %%% loop 108 | %%% StateName <----- . 109 | %%% 110 | %%% handle_event <----- . 111 | %%% 112 | %%% handle__sunc_event <----- . 113 | %%% 114 | %%% handle_info <----- . 115 | %%% 116 | %%% terminate <----- . 117 | %%% 118 | %%% 119 | %%% --------------------------------------------------- 120 | 121 | -export([start/3, start/4, 122 | start_link/3, start_link/4, 123 | send_event/2, sync_send_event/2, sync_send_event/3, 124 | send_all_state_event/2, 125 | sync_send_all_state_event/2, sync_send_all_state_event/3, 126 | reply/2, 127 | start_timer/2,send_event_after/2,cancel_timer/1, 128 | enter_loop/4, enter_loop/5, enter_loop/6, wake_hib/7]). 129 | 130 | %% Internal exports 131 | -export([init_it/6, print_event/3, 132 | system_continue/3, 133 | system_terminate/4, 134 | system_code_change/4, 135 | format_status/2]). 136 | 137 | -import(error_logger , [format/2]). 138 | 139 | %%% Internal gen_fsm state 140 | %%% This state is used to defined resource control values: 141 | -record(limits, {max_queue :: non_neg_integer() | undefined}). 142 | 143 | %%% --------------------------------------------------- 144 | %%% Interface functions. 145 | %%% --------------------------------------------------- 146 | 147 | -callback init(Args :: term()) -> 148 | {ok, StateName :: atom(), StateData :: term()} | 149 | {ok, StateName :: atom(), StateData :: term(), timeout() | hibernate} | 150 | {stop, Reason :: term()} | ignore. 151 | -callback handle_event(Event :: term(), StateName :: atom(), 152 | StateData :: term()) -> 153 | {next_state, NextStateName :: atom(), NewStateData :: term()} | 154 | {next_state, NextStateName :: atom(), NewStateData :: term(), 155 | timeout() | hibernate} | 156 | {migrate, NewStateData :: term(), 157 | {Node :: atom(), M :: atom(), F :: atom(), A :: list()}, 158 | Timeout :: timeout()} | 159 | {stop, Reason :: term(), NewStateData :: term()}. 160 | -callback handle_sync_event(Event :: term(), From :: {pid(), Tag :: term()}, 161 | StateName :: atom(), StateData :: term()) -> 162 | {reply, Reply :: term(), NextStateName :: atom(), NewStateData :: term()} | 163 | {reply, Reply :: term(), NextStateName :: atom(), NewStateData :: term(), 164 | timeout() | hibernate} | 165 | {next_state, NextStateName :: atom(), NewStateData :: term()} | 166 | {next_state, NextStateName :: atom(), NewStateData :: term(), 167 | timeout() | hibernate} | 168 | {migrate, NewStateData :: term(), 169 | {Node :: atom(), M :: atom(), F :: atom(), A :: list()}, 170 | Timeout :: timeout()} | 171 | {stop, Reason :: term(), Reply :: term(), NewStateData :: term()} | 172 | {stop, Reason :: term(), NewStateData :: term()}. 173 | -callback handle_info(Info :: term(), StateName :: atom(), 174 | StateData :: term()) -> 175 | {next_state, NextStateName :: atom(), NewStateData :: term()} | 176 | {next_state, NextStateName :: atom(), NewStateData :: term(), 177 | timeout() | hibernate} | 178 | {migrate, NewStateData :: term(), 179 | {Node :: atom(), M :: atom(), F :: atom(), A :: list()}, 180 | Timeout :: timeout()} | 181 | {stop, Reason :: normal | term(), NewStateData :: term()}. 182 | -callback terminate(Reason :: normal | shutdown | {shutdown, term()} 183 | | term(), StateName :: atom(), StateData :: term()) -> 184 | term(). 185 | -callback code_change(OldVsn :: term() | {down, term()}, StateName :: atom(), 186 | StateData :: term(), Extra :: term()) -> 187 | {ok, NextStateName :: atom(), NewStateData :: term()}. 188 | 189 | %%% --------------------------------------------------- 190 | %%% Starts a generic state machine. 191 | %%% start(Mod, Args, Options) 192 | %%% start(Name, Mod, Args, Options) 193 | %%% start_link(Mod, Args, Options) 194 | %%% start_link(Name, Mod, Args, Options) where: 195 | %%% Name ::= {local, atom()} | {global, atom()} 196 | %%% Mod ::= atom(), callback module implementing the 'real' fsm 197 | %%% Args ::= term(), init arguments (to Mod:init/1) 198 | %%% Options ::= [{debug, [Flag]}] 199 | %%% Flag ::= trace | log | {logfile, File} | statistics | debug 200 | %%% (debug == log && statistics) 201 | %%% Returns: {ok, Pid} | 202 | %%% {error, {already_started, Pid}} | 203 | %%% {error, Reason} 204 | %%% --------------------------------------------------- 205 | start(Mod, Args, Options) -> 206 | gen:start(?MODULE, nolink, Mod, Args, Options). 207 | 208 | start(Name, Mod, Args, Options) -> 209 | gen:start(?MODULE, nolink, Name, Mod, Args, Options). 210 | 211 | start_link(Mod, Args, Options) -> 212 | gen:start(?MODULE, link, Mod, Args, Options). 213 | 214 | start_link(Name, Mod, Args, Options) -> 215 | gen:start(?MODULE, link, Name, Mod, Args, Options). 216 | 217 | 218 | send_event({global, Name}, Event) -> 219 | catch global:send(Name, {'$gen_event', Event}), 220 | ok; 221 | send_event(Name, Event) -> 222 | Name ! {'$gen_event', Event}, 223 | ok. 224 | 225 | sync_send_event(Name, Event) -> 226 | case catch gen:call(Name, '$gen_sync_event', Event) of 227 | {ok,Res} -> 228 | Res; 229 | {'EXIT',Reason} -> 230 | exit({Reason, {?MODULE, sync_send_event, [Name, Event]}}) 231 | end. 232 | 233 | sync_send_event(Name, Event, Timeout) -> 234 | case catch gen:call(Name, '$gen_sync_event', Event, Timeout) of 235 | {ok,Res} -> 236 | Res; 237 | {'EXIT',Reason} -> 238 | exit({Reason, {?MODULE, sync_send_event, [Name, Event, Timeout]}}) 239 | end. 240 | 241 | send_all_state_event({global, Name}, Event) -> 242 | catch global:send(Name, {'$gen_all_state_event', Event}), 243 | ok; 244 | send_all_state_event(Name, Event) -> 245 | Name ! {'$gen_all_state_event', Event}, 246 | ok. 247 | 248 | sync_send_all_state_event(Name, Event) -> 249 | case catch gen:call(Name, '$gen_sync_all_state_event', Event) of 250 | {ok,Res} -> 251 | Res; 252 | {'EXIT',Reason} -> 253 | exit({Reason, {?MODULE, sync_send_all_state_event, [Name, Event]}}) 254 | end. 255 | 256 | sync_send_all_state_event(Name, Event, Timeout) -> 257 | case catch gen:call(Name, '$gen_sync_all_state_event', Event, Timeout) of 258 | {ok,Res} -> 259 | Res; 260 | {'EXIT',Reason} -> 261 | exit({Reason, {?MODULE, sync_send_all_state_event, 262 | [Name, Event, Timeout]}}) 263 | end. 264 | 265 | %% Designed to be only callable within one of the callbacks 266 | %% hence using the self() of this instance of the process. 267 | %% This is to ensure that timers don't go astray in global 268 | %% e.g. when straddling a failover, or turn up in a restarted 269 | %% instance of the process. 270 | 271 | %% Returns Ref, sends event {timeout,Ref,Msg} after Time 272 | %% to the (then) current state. 273 | start_timer(Time, Msg) -> 274 | erlang:start_timer(Time, self(), {'$gen_timer', Msg}). 275 | 276 | %% Returns Ref, sends Event after Time to the (then) current state. 277 | send_event_after(Time, Event) -> 278 | erlang:start_timer(Time, self(), {'$gen_event', Event}). 279 | 280 | %% Returns the remaining time for the timer if Ref referred to 281 | %% an active timer/send_event_after, false otherwise. 282 | cancel_timer(Ref) -> 283 | case erlang:cancel_timer(Ref) of 284 | false -> 285 | receive {timeout, Ref, _} -> 0 286 | after 0 -> false 287 | end; 288 | RemainingTime -> 289 | RemainingTime 290 | end. 291 | 292 | %% enter_loop/4,5,6 293 | %% Makes an existing process into a gen_fsm. 294 | %% The calling process will enter the gen_fsm receive loop and become a 295 | %% gen_fsm process. 296 | %% The process *must* have been started using one of the start functions 297 | %% in proc_lib, see proc_lib(3). 298 | %% The user is responsible for any initialization of the process, 299 | %% including registering a name for it. 300 | enter_loop(Mod, Options, StateName, StateData) -> 301 | enter_loop(Mod, Options, StateName, StateData, self(), infinity). 302 | 303 | enter_loop(Mod, Options, StateName, StateData, ServerName = {_,_}) -> 304 | enter_loop(Mod, Options, StateName, StateData, ServerName,infinity); 305 | enter_loop(Mod, Options, StateName, StateData, Timeout) -> 306 | enter_loop(Mod, Options, StateName, StateData, self(), Timeout). 307 | 308 | enter_loop(Mod, Options, StateName, StateData, ServerName, Timeout) -> 309 | Name = get_proc_name(ServerName), 310 | Parent = get_parent(), 311 | Debug = debug_options(Options), 312 | Limits = limit_options(Options), 313 | Queue = queue:new(), 314 | QueueLen = 0, 315 | loop(Parent, Name, StateName, StateData, Mod, Timeout, Debug, 316 | Limits, Queue, QueueLen). 317 | 318 | get_proc_name(Pid) when is_pid(Pid) -> 319 | Pid; 320 | get_proc_name({local, Name}) -> 321 | case process_info(self(), registered_name) of 322 | {registered_name, Name} -> 323 | Name; 324 | {registered_name, _Name} -> 325 | exit(process_not_registered); 326 | [] -> 327 | exit(process_not_registered) 328 | end; 329 | get_proc_name({global, Name}) -> 330 | case global:whereis_name(Name) of 331 | undefined -> 332 | exit(process_not_registered_globally); 333 | Pid when Pid==self() -> 334 | Name; 335 | _Pid -> 336 | exit(process_not_registered_globally) 337 | end. 338 | 339 | get_parent() -> 340 | case get('$ancestors') of 341 | [Parent | _] when is_pid(Parent) -> 342 | Parent; 343 | [Parent | _] when is_atom(Parent) -> 344 | name_to_pid(Parent); 345 | _ -> 346 | exit(process_was_not_started_by_proc_lib) 347 | end. 348 | 349 | name_to_pid(Name) -> 350 | case whereis(Name) of 351 | undefined -> 352 | case global:whereis_name(Name) of 353 | undefined -> 354 | exit(could_not_find_registerd_name); 355 | Pid -> 356 | Pid 357 | end; 358 | Pid -> 359 | Pid 360 | end. 361 | 362 | %%% --------------------------------------------------- 363 | %%% Initiate the new process. 364 | %%% Register the name using the Rfunc function 365 | %%% Calls the Mod:init/Args function. 366 | %%% Finally an acknowledge is sent to Parent and the main 367 | %%% loop is entered. 368 | %%% --------------------------------------------------- 369 | init_it(Starter, self, Name, Mod, Args, Options) -> 370 | init_it(Starter, self(), Name, Mod, Args, Options); 371 | init_it(Starter, Parent, Name0, Mod, Args, Options) -> 372 | Name = name(Name0), 373 | Debug = debug_options(Options), 374 | Limits = limit_options(Options), 375 | Queue = queue:new(), 376 | QueueLen = 0, 377 | case catch Mod:init(Args) of 378 | {ok, StateName, StateData} -> 379 | proc_lib:init_ack(Starter, {ok, self()}), 380 | loop(Parent, Name, StateName, StateData, Mod, infinity, Debug, Limits, Queue, QueueLen); 381 | {ok, StateName, StateData, Timeout} -> 382 | proc_lib:init_ack(Starter, {ok, self()}), 383 | loop(Parent, Name, StateName, StateData, Mod, Timeout, Debug, Limits, Queue, QueueLen); 384 | {stop, Reason} -> 385 | proc_lib:init_ack(Starter, {error, Reason}), 386 | exit(Reason); 387 | ignore -> 388 | proc_lib:init_ack(Starter, ignore), 389 | exit(normal); 390 | {'EXIT', Reason} -> 391 | proc_lib:init_ack(Starter, {error, Reason}), 392 | exit(Reason); 393 | Else -> 394 | Error = {bad_return_value, Else}, 395 | proc_lib:init_ack(Starter, {error, Error}), 396 | exit(Error) 397 | end. 398 | 399 | name({local,Name}) -> Name; 400 | name({global,Name}) -> Name; 401 | name(Pid) when is_pid(Pid) -> Pid. 402 | 403 | %%----------------------------------------------------------------- 404 | %% The MAIN loop 405 | %%----------------------------------------------------------------- 406 | loop(Parent, Name, StateName, StateData, Mod, hibernate, Debug, 407 | Limits, Queue, QueueLen) 408 | when QueueLen > 0 -> 409 | case queue:out(Queue) of 410 | {{value, Msg}, Queue1} -> 411 | decode_msg(Msg, Parent, Name, StateName, StateData, Mod, hibernate, 412 | Debug, Limits, Queue1, QueueLen - 1, false); 413 | {empty, _} -> 414 | Reason = internal_queue_error, 415 | error_info(Mod, Reason, Name, hibernate, StateName, StateData, Debug), 416 | exit(Reason) 417 | end; 418 | loop(Parent, Name, StateName, StateData, Mod, hibernate, Debug, 419 | Limits, _Queue, _QueueLen) -> 420 | proc_lib:hibernate(?MODULE,wake_hib, 421 | [Parent, Name, StateName, StateData, Mod, 422 | Debug, Limits]); 423 | %% First we test if we have reach a defined limit ... 424 | loop(Parent, Name, StateName, StateData, Mod, Time, Debug, 425 | Limits, Queue, QueueLen) -> 426 | try 427 | message_queue_len(Limits, QueueLen) 428 | %% TODO: We can add more limit checking here... 429 | catch 430 | {process_limit, Limit} -> 431 | Reason = {process_limit, Limit}, 432 | Msg = {'EXIT', Parent, {error, {process_limit, Limit}}}, 433 | terminate(Reason, Name, Msg, Mod, StateName, StateData, Debug, 434 | queue:new()) 435 | end, 436 | process_message(Parent, Name, StateName, StateData, 437 | Mod, Time, Debug, Limits, Queue, QueueLen). 438 | %% ... then we can process a new message: 439 | process_message(Parent, Name, StateName, StateData, Mod, Time, Debug, 440 | Limits, Queue, QueueLen) -> 441 | {Msg, Queue1, QueueLen1} = collect_messages(Queue, QueueLen, Time), 442 | decode_msg(Msg,Parent, Name, StateName, StateData, Mod, Time, 443 | Debug, Limits, Queue1, QueueLen1, false). 444 | 445 | collect_messages(Queue, QueueLen, Time) -> 446 | receive 447 | Input -> 448 | case Input of 449 | {'EXIT', _Parent, priority_shutdown} -> 450 | {Input, Queue, QueueLen}; 451 | _ -> 452 | collect_messages( 453 | queue:in(Input, Queue), QueueLen + 1, Time) 454 | end 455 | after 0 -> 456 | case queue:out(Queue) of 457 | {{value, Msg}, Queue1} -> 458 | {Msg, Queue1, QueueLen - 1}; 459 | {empty, _} -> 460 | receive 461 | Input -> 462 | {Input, Queue, QueueLen} 463 | after Time -> 464 | {{'$gen_event', timeout}, Queue, QueueLen} 465 | end 466 | end 467 | end. 468 | 469 | 470 | wake_hib(Parent, Name, StateName, StateData, Mod, Debug, 471 | Limits) -> 472 | Msg = receive 473 | Input -> 474 | Input 475 | end, 476 | Queue = queue:new(), 477 | QueueLen = 0, 478 | decode_msg(Msg, Parent, Name, StateName, StateData, Mod, hibernate, 479 | Debug, Limits, Queue, QueueLen, true). 480 | 481 | decode_msg(Msg,Parent, Name, StateName, StateData, Mod, Time, Debug, 482 | Limits, Queue, QueueLen, Hib) -> 483 | put('$internal_queue_len', QueueLen), 484 | case Msg of 485 | {system, From, Req} -> 486 | sys:handle_system_msg(Req, From, Parent, ?MODULE, Debug, 487 | [Name, StateName, StateData, 488 | Mod, Time, Limits, Queue, QueueLen], Hib); 489 | {'EXIT', Parent, Reason} -> 490 | terminate(Reason, Name, Msg, Mod, StateName, StateData, Debug, 491 | Queue); 492 | _Msg when Debug == [] -> 493 | handle_msg(Msg, Parent, Name, StateName, StateData, 494 | Mod, Time, Limits, Queue, QueueLen); 495 | _Msg -> 496 | Debug1 = sys:handle_debug(Debug, fun print_event/3, 497 | {Name, StateName}, {in, Msg}), 498 | handle_msg(Msg, Parent, Name, StateName, StateData, 499 | Mod, Time, Debug1, Limits, Queue, QueueLen) 500 | end. 501 | 502 | %%----------------------------------------------------------------- 503 | %% Callback functions for system messages handling. 504 | %%----------------------------------------------------------------- 505 | system_continue(Parent, Debug, [Name, StateName, StateData, 506 | Mod, Time, Limits, Queue, QueueLen]) -> 507 | loop(Parent, Name, StateName, StateData, Mod, Time, Debug, 508 | Limits, Queue, QueueLen). 509 | 510 | -spec system_terminate(term(), _, _, [term(),...]) -> no_return(). 511 | 512 | system_terminate(Reason, _Parent, Debug, 513 | [Name, StateName, StateData, Mod, _Time, 514 | _Limits, Queue, _QueueLen]) -> 515 | terminate(Reason, Name, [], Mod, StateName, StateData, Debug, Queue). 516 | 517 | system_code_change([Name, StateName, StateData, Mod, Time, 518 | Limits, Queue, QueueLen], 519 | _Module, OldVsn, Extra) -> 520 | case catch Mod:code_change(OldVsn, StateName, StateData, Extra) of 521 | {ok, NewStateName, NewStateData} -> 522 | {ok, [Name, NewStateName, NewStateData, Mod, Time, 523 | Limits, Queue, QueueLen]}; 524 | Else -> Else 525 | end. 526 | 527 | %%----------------------------------------------------------------- 528 | %% Format debug messages. Print them as the call-back module sees 529 | %% them, not as the real erlang messages. Use trace for that. 530 | %%----------------------------------------------------------------- 531 | print_event(Dev, {in, Msg}, {Name, StateName}) -> 532 | case Msg of 533 | {'$gen_event', Event} -> 534 | io:format(Dev, "*DBG* ~p got event ~p in state ~w~n", 535 | [Name, Event, StateName]); 536 | {'$gen_all_state_event', Event} -> 537 | io:format(Dev, 538 | "*DBG* ~p got all_state_event ~p in state ~w~n", 539 | [Name, Event, StateName]); 540 | {timeout, Ref, {'$gen_timer', Message}} -> 541 | io:format(Dev, 542 | "*DBG* ~p got timer ~p in state ~w~n", 543 | [Name, {timeout, Ref, Message}, StateName]); 544 | {timeout, _Ref, {'$gen_event', Event}} -> 545 | io:format(Dev, 546 | "*DBG* ~p got timer ~p in state ~w~n", 547 | [Name, Event, StateName]); 548 | _ -> 549 | io:format(Dev, "*DBG* ~p got ~p in state ~w~n", 550 | [Name, Msg, StateName]) 551 | end; 552 | print_event(Dev, {out, Msg, To, StateName}, Name) -> 553 | io:format(Dev, "*DBG* ~p sent ~p to ~w~n" 554 | " and switched to state ~w~n", 555 | [Name, Msg, To, StateName]); 556 | print_event(Dev, return, {Name, StateName}) -> 557 | io:format(Dev, "*DBG* ~p switched to state ~w~n", 558 | [Name, StateName]). 559 | 560 | relay_messages(MRef, TRef, Clone, Queue) -> 561 | lists:foreach( 562 | fun(Msg) -> Clone ! Msg end, 563 | queue:to_list(Queue)), 564 | relay_messages(MRef, TRef, Clone). 565 | 566 | relay_messages(MRef, TRef, Clone) -> 567 | receive 568 | {'DOWN', MRef, process, Clone, _Reason} -> 569 | normal; 570 | {'EXIT', _Parent, _Reason} -> 571 | {migrated, Clone}; 572 | {timeout, TRef, timeout} -> 573 | {migrated, Clone}; 574 | Msg -> 575 | Clone ! Msg, 576 | relay_messages(MRef, TRef, Clone) 577 | end. 578 | 579 | handle_msg(Msg, Parent, Name, StateName, StateData, Mod, _Time, 580 | Limits, Queue, QueueLen) -> %No debug here 581 | From = from(Msg), 582 | case catch dispatch(Msg, Mod, StateName, StateData) of 583 | {next_state, NStateName, NStateData} -> 584 | loop(Parent, Name, NStateName, NStateData, 585 | Mod, infinity, [], Limits, Queue, QueueLen); 586 | {next_state, NStateName, NStateData, Time1} -> 587 | loop(Parent, Name, NStateName, NStateData, Mod, Time1, [], 588 | Limits, Queue, QueueLen); 589 | {reply, Reply, NStateName, NStateData} when From =/= undefined -> 590 | reply(From, Reply), 591 | loop(Parent, Name, NStateName, NStateData, 592 | Mod, infinity, [], Limits, Queue, QueueLen); 593 | {reply, Reply, NStateName, NStateData, Time1} when From =/= undefined -> 594 | reply(From, Reply), 595 | loop(Parent, Name, NStateName, NStateData, Mod, Time1, [], 596 | Limits, Queue, QueueLen); 597 | {migrate, NStateData, {Node, M, F, A}, Time1} -> 598 | RPCTimeout = if Time1 == 0 -> 599 | %% We don't care about a delay, 600 | %% so we set it one minute 601 | 60000; 602 | true -> 603 | Time1 604 | end, 605 | Now = p1_time_compat:monotonic_time(milli_seconds), 606 | Reason = case catch rpc_call(Node, M, F, A, RPCTimeout) of 607 | {ok, Clone} -> 608 | process_flag(trap_exit, true), 609 | MRef = erlang:monitor(process, Clone), 610 | NowDiff = p1_time_compat:monotonic_time(milli_seconds) - Now, 611 | TimeLeft = lists:max([Time1 - NowDiff, 0]), 612 | TRef = erlang:start_timer(TimeLeft, self(), timeout), 613 | relay_messages(MRef, TRef, Clone, Queue); 614 | _ -> 615 | normal 616 | end, 617 | Queue1 = 618 | case Reason of 619 | normal -> Queue; 620 | _ -> queue:new() 621 | end, 622 | terminate(Reason, Name, Msg, Mod, StateName, NStateData, [], 623 | Queue1); 624 | {stop, Reason, NStateData} -> 625 | terminate(Reason, Name, Msg, Mod, StateName, NStateData, [], Queue); 626 | {stop, Reason, Reply, NStateData} when From =/= undefined -> 627 | {'EXIT', R} = (catch terminate(Reason, Name, Msg, Mod, 628 | StateName, NStateData, [], Queue)), 629 | reply(From, Reply), 630 | exit(R); 631 | {'EXIT', What} -> 632 | terminate(What, Name, Msg, Mod, StateName, StateData, [], Queue); 633 | Reply -> 634 | terminate({bad_return_value, Reply}, 635 | Name, Msg, Mod, StateName, StateData, [], Queue) 636 | end. 637 | 638 | handle_msg(Msg, Parent, Name, StateName, StateData, 639 | Mod, _Time, Debug, Limits, Queue, QueueLen) -> 640 | From = from(Msg), 641 | case catch dispatch(Msg, Mod, StateName, StateData) of 642 | {next_state, NStateName, NStateData} -> 643 | Debug1 = sys:handle_debug(Debug, fun print_event/3, 644 | {Name, NStateName}, return), 645 | loop(Parent, Name, NStateName, NStateData, 646 | Mod, infinity, Debug1, Limits, Queue, QueueLen); 647 | {next_state, NStateName, NStateData, Time1} -> 648 | Debug1 = sys:handle_debug(Debug, fun print_event/3, 649 | {Name, NStateName}, return), 650 | loop(Parent, Name, NStateName, NStateData, 651 | Mod, Time1, Debug1, Limits, Queue, QueueLen); 652 | {reply, Reply, NStateName, NStateData} when From =/= undefined -> 653 | Debug1 = reply(Name, From, Reply, Debug, NStateName), 654 | loop(Parent, Name, NStateName, NStateData, 655 | Mod, infinity, Debug1, Limits, Queue, QueueLen); 656 | {reply, Reply, NStateName, NStateData, Time1} when From =/= undefined -> 657 | Debug1 = reply(Name, From, Reply, Debug, NStateName), 658 | loop(Parent, Name, NStateName, NStateData, 659 | Mod, Time1, Debug1, Limits, Queue, QueueLen); 660 | {migrate, NStateData, {Node, M, F, A}, Time1} -> 661 | RPCTimeout = if Time1 == 0 -> 662 | %% We don't care about a delay, 663 | %% so we set it one minute 664 | 60000; 665 | true -> 666 | Time1 667 | end, 668 | Now = p1_time_compat:monotonic_time(milli_seconds), 669 | Reason = case catch rpc_call(Node, M, F, A, RPCTimeout) of 670 | {ok, Clone} -> 671 | process_flag(trap_exit, true), 672 | MRef = erlang:monitor(process, Clone), 673 | NowDiff = p1_time_compat:monotonic_time(milli_seconds) - Now, 674 | TimeLeft = lists:max([Time1 - NowDiff, 0]), 675 | TRef = erlang:start_timer(TimeLeft, self(), timeout), 676 | relay_messages(MRef, TRef, Clone, Queue); 677 | _ -> 678 | normal 679 | end, 680 | Queue1 = 681 | case Reason of 682 | normal -> Queue; 683 | _ -> queue:new() 684 | end, 685 | terminate(Reason, Name, Msg, Mod, StateName, NStateData, Debug, 686 | Queue1); 687 | {stop, Reason, NStateData} -> 688 | terminate(Reason, Name, Msg, Mod, StateName, NStateData, Debug, 689 | Queue); 690 | {stop, Reason, Reply, NStateData} when From =/= undefined -> 691 | {'EXIT', R} = (catch terminate(Reason, Name, Msg, Mod, 692 | StateName, NStateData, Debug, 693 | Queue)), 694 | reply(Name, From, Reply, Debug, StateName), 695 | exit(R); 696 | {'EXIT', What} -> 697 | terminate(What, Name, Msg, Mod, StateName, StateData, Debug, Queue); 698 | Reply -> 699 | terminate({bad_return_value, Reply}, 700 | Name, Msg, Mod, StateName, StateData, Debug, Queue) 701 | end. 702 | 703 | dispatch({'$gen_event', Event}, Mod, StateName, StateData) -> 704 | Mod:StateName(Event, StateData); 705 | dispatch({'$gen_all_state_event', Event}, Mod, StateName, StateData) -> 706 | Mod:handle_event(Event, StateName, StateData); 707 | dispatch({'$gen_sync_event', From, Event}, Mod, StateName, StateData) -> 708 | Mod:StateName(Event, From, StateData); 709 | dispatch({'$gen_sync_all_state_event', From, Event}, 710 | Mod, StateName, StateData) -> 711 | Mod:handle_sync_event(Event, From, StateName, StateData); 712 | dispatch({timeout, Ref, {'$gen_timer', Msg}}, Mod, StateName, StateData) -> 713 | Mod:StateName({timeout, Ref, Msg}, StateData); 714 | dispatch({timeout, _Ref, {'$gen_event', Event}}, Mod, StateName, StateData) -> 715 | Mod:StateName(Event, StateData); 716 | dispatch(Info, Mod, StateName, StateData) -> 717 | Mod:handle_info(Info, StateName, StateData). 718 | 719 | from({'$gen_sync_event', From, _Event}) -> From; 720 | from({'$gen_sync_all_state_event', From, _Event}) -> From; 721 | from(_) -> undefined. 722 | 723 | %% Send a reply to the client. 724 | reply({To, Tag}, Reply) -> 725 | catch To ! {Tag, Reply}. 726 | 727 | reply(Name, {To, Tag}, Reply, Debug, StateName) -> 728 | reply({To, Tag}, Reply), 729 | sys:handle_debug(Debug, fun print_event/3, Name, 730 | {out, Reply, To, StateName}). 731 | 732 | %%% --------------------------------------------------- 733 | %%% Terminate the server. 734 | %%% --------------------------------------------------- 735 | 736 | terminate(Reason, Name, Msg, Mod, StateName, StateData, Debug, Queue) -> 737 | lists:foreach( 738 | fun(Message) -> self() ! Message end, 739 | queue:to_list(Queue)), 740 | case catch Mod:terminate(Reason, StateName, StateData) of 741 | {'EXIT', R} -> 742 | error_info(Mod, R, Name, Msg, StateName, StateData, Debug), 743 | exit(R); 744 | _ -> 745 | case Reason of 746 | normal -> 747 | exit(normal); 748 | shutdown -> 749 | exit(shutdown); 750 | priority_shutdown -> 751 | %% Priority shutdown should be considered as 752 | %% shutdown by SASL 753 | exit(shutdown); 754 | {process_limit, _Limit} -> 755 | exit(Reason); 756 | {migrated, _Clone} -> 757 | exit(normal); 758 | _ -> 759 | error_info(Mod, Reason, Name, Msg, StateName, StateData, Debug), 760 | exit(Reason) 761 | end 762 | end. 763 | 764 | error_info(Mod, Reason, Name, Msg, StateName, StateData, Debug) -> 765 | Reason1 = 766 | case Reason of 767 | {undef,[{M,F,A}|MFAs]} -> 768 | case code:is_loaded(M) of 769 | false -> 770 | {'module could not be loaded',[{M,F,A}|MFAs]}; 771 | _ -> 772 | case erlang:function_exported(M, F, length(A)) of 773 | true -> 774 | Reason; 775 | false -> 776 | {'function not exported',[{M,F,A}|MFAs]} 777 | end 778 | end; 779 | _ -> 780 | Reason 781 | end, 782 | StateToPrint = case erlang:function_exported(Mod, print_state, 1) of 783 | true -> (catch Mod:print_state(StateData)); 784 | false -> StateData 785 | end, 786 | Str = "** State machine ~p terminating \n" ++ 787 | get_msg_str(Msg) ++ 788 | "** When State == ~p~n" 789 | "** Data == ~p~n" 790 | "** Reason for termination = ~n** ~p~n", 791 | format(Str, [Name, get_msg(Msg), StateName, StateToPrint, Reason1]), 792 | sys:print_log(Debug), 793 | ok. 794 | 795 | get_msg_str({'$gen_event', _Event}) -> 796 | "** Last event in was ~p~n"; 797 | get_msg_str({'$gen_sync_event', _Event}) -> 798 | "** Last sync event in was ~p~n"; 799 | get_msg_str({'$gen_all_state_event', _Event}) -> 800 | "** Last event in was ~p (for all states)~n"; 801 | get_msg_str({'$gen_sync_all_state_event', _Event}) -> 802 | "** Last sync event in was ~p (for all states)~n"; 803 | get_msg_str({timeout, _Ref, {'$gen_timer', _Msg}}) -> 804 | "** Last timer event in was ~p~n"; 805 | get_msg_str({timeout, _Ref, {'$gen_event', _Msg}}) -> 806 | "** Last timer event in was ~p~n"; 807 | get_msg_str(_Msg) -> 808 | "** Last message in was ~p~n". 809 | 810 | get_msg({'$gen_event', Event}) -> Event; 811 | get_msg({'$gen_sync_event', Event}) -> Event; 812 | get_msg({'$gen_all_state_event', Event}) -> Event; 813 | get_msg({'$gen_sync_all_state_event', Event}) -> Event; 814 | get_msg({timeout, Ref, {'$gen_timer', Msg}}) -> {timeout, Ref, Msg}; 815 | get_msg({timeout, _Ref, {'$gen_event', Event}}) -> Event; 816 | get_msg(Msg) -> Msg. 817 | 818 | %%----------------------------------------------------------------- 819 | %% Status information 820 | %%----------------------------------------------------------------- 821 | format_status(Opt, StatusData) -> 822 | [PDict, SysState, Parent, Debug, 823 | [Name, StateName, StateData, Mod, _Time, _Limits, _Queue, _QueueLen]] = 824 | StatusData, 825 | NameTag = if is_pid(Name) -> 826 | pid_to_list(Name); 827 | is_atom(Name) -> 828 | Name 829 | end, 830 | Header = lists:concat(["Status for state machine ", NameTag]), 831 | Log = sys_get_debug(log, Debug, []), 832 | Specific = 833 | case erlang:function_exported(Mod, format_status, 2) of 834 | true -> 835 | case catch Mod:format_status(Opt,[PDict,StateData]) of 836 | {'EXIT', _} -> [{data, [{"StateData", StateData}]}]; 837 | Else -> Else 838 | end; 839 | _ -> 840 | [{data, [{"StateData", StateData}]}] 841 | end, 842 | [{header, Header}, 843 | {data, [{"Status", SysState}, 844 | {"Parent", Parent}, 845 | {"Logged events", Log}, 846 | {"StateName", StateName}]} | 847 | Specific]. 848 | 849 | -ifdef(USE_OLD_SYS_GET_DEBUG). 850 | sys_get_debug(Item, Debug, Default) -> sys:get_debug(Item, Debug, Default). 851 | -else. 852 | sys_get_debug(log, Debug, _Default) -> sys:get_log(Debug). 853 | -endif. 854 | 855 | %%----------------------------------------------------------------- 856 | %% Resources limit management 857 | %%----------------------------------------------------------------- 858 | %% Extract know limit options 859 | limit_options(Options) -> 860 | limit_options(Options, #limits{}). 861 | limit_options([], Limits) -> 862 | Limits; 863 | %% Maximum number of messages allowed in the process message queue 864 | limit_options([{max_queue,N}|Options], Limits) 865 | when is_integer(N) -> 866 | NewLimits = Limits#limits{max_queue=N}, 867 | limit_options(Options, NewLimits); 868 | limit_options([_|Options], Limits) -> 869 | limit_options(Options, Limits). 870 | 871 | %% Throw max_queue if we have reach the max queue size 872 | %% Returns ok otherwise 873 | message_queue_len(#limits{max_queue = undefined}, _QueueLen) -> 874 | ok; 875 | message_queue_len(#limits{max_queue = MaxQueue}, QueueLen) -> 876 | Pid = self(), 877 | case process_info(Pid, message_queue_len) of 878 | {message_queue_len, N} when N + QueueLen > MaxQueue -> 879 | throw({process_limit, {max_queue, N + QueueLen}}); 880 | _ -> 881 | ok 882 | end. 883 | 884 | rpc_call(Node, Mod, Fun, Args, Timeout) -> 885 | Ref = make_ref(), 886 | Caller = self(), 887 | F = fun() -> 888 | group_leader(whereis(user), self()), 889 | case catch apply(Mod, Fun, Args) of 890 | {'EXIT', _} = Err -> 891 | Caller ! {Ref, {badrpc, Err}}; 892 | Result -> 893 | Caller ! {Ref, Result} 894 | end 895 | end, 896 | Pid = spawn(Node, F), 897 | MRef = erlang:monitor(process, Pid), 898 | receive 899 | {Ref, Result} -> 900 | erlang:demonitor(MRef, [flush]), 901 | Result; 902 | {'DOWN', MRef, _, _, noconnection = Reason} -> 903 | {badrpc, Reason} 904 | after Timeout -> 905 | erlang:demonitor(MRef, [flush]), 906 | catch exit(Pid, kill), 907 | receive 908 | {Ref, Result} -> 909 | Result 910 | after 0 -> 911 | {badrpc, timeout} 912 | end 913 | end. 914 | 915 | opt(Op, [{Op, Value}|_]) -> 916 | {ok, Value}; 917 | opt(Op, [_|Options]) -> 918 | opt(Op, Options); 919 | opt(_, []) -> 920 | false. 921 | 922 | debug_options(Opts) -> 923 | case opt(debug, Opts) of 924 | {ok, Options} -> sys:debug_options(Options); 925 | _ -> [] 926 | end. 927 | -------------------------------------------------------------------------------- /src/p1_http.erl: -------------------------------------------------------------------------------- 1 | %%%------------------------------------------------------------------- 2 | %%% File : p1_http.erl 3 | %%% Author : Emilio Bustos 4 | %%% Purpose : Provide a common API for inets / lhttpc / ibrowse 5 | %%% Created : 29 Jul 2010 by Emilio Bustos 6 | %%% 7 | %%% 8 | %%% Copyright (C) 2002-2025 ProcessOne, SARL. All Rights Reserved. 9 | %%% 10 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 11 | %%% you may not use this file except in compliance with the License. 12 | %%% You may obtain a copy of the License at 13 | %%% 14 | %%% http://www.apache.org/licenses/LICENSE-2.0 15 | %%% 16 | %%% Unless required by applicable law or agreed to in writing, software 17 | %%% distributed under the License is distributed on an "AS IS" BASIS, 18 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 19 | %%% See the License for the specific language governing permissions and 20 | %%% limitations under the License. 21 | %%% 22 | %%%------------------------------------------------------------------- 23 | 24 | -module(p1_http). 25 | 26 | -author('ebustos@process-one.net'). 27 | 28 | -export([start/0, stop/0, get/1, get/2, post/2, post/3, 29 | request/3, request/4, request/5, 30 | get_pool_size/0, set_pool_size/1]). 31 | 32 | -type header() :: {string() | atom(), string()}. 33 | 34 | -type headers() :: [header()]. 35 | 36 | -type option() :: {connect_timeout, timeout()} | 37 | {timeout, timeout()} | {send_retry, non_neg_integer()} | 38 | {partial_upload, non_neg_integer() | infinity} | 39 | {partial_download, pid(), non_neg_integer() | infinity}. 40 | 41 | -type options() :: [option()]. 42 | 43 | -type result() :: {ok, 44 | {{pos_integer(), string()}, headers(), string()}} | 45 | {error, atom()}. 46 | 47 | -ifdef(USE_IBROWSE). 48 | 49 | start() -> 50 | application:start(ibrowse). 51 | 52 | stop() -> 53 | application:stop(ibrowse). 54 | 55 | %% @doc Sends a request with a body. 56 | %% Would be the same as calling 57 | %% `request(Method, URL, Hdrs, Body, [])', that is {@link request/5} 58 | %% with no options. 59 | %% @end 60 | %% @see request/5 61 | request(Method, URL, Hdrs, Body, Opts) -> 62 | TimeOut = proplists:get_value(timeout, Opts, infinity), 63 | Options = [{inactivity_timeout, TimeOut} 64 | | proplists:delete(timeout, Opts)], 65 | case ibrowse:send_req(URL, Hdrs, Method, Body, Options) 66 | of 67 | {ok, Status, Headers, Response} -> 68 | {ok, jlib:binary_to_integer(Status), Headers, 69 | Response}; 70 | {error, Reason} -> {error, Reason} 71 | end. 72 | 73 | get_pool_size() -> 74 | application:get_env(ibrowse, default_max_sessions, 10). 75 | 76 | set_pool_size(Size) -> 77 | application:set_env(ibrowse, default_max_sessions, Size). 78 | 79 | -else. 80 | 81 | -ifdef(USE_LHTTPC). 82 | 83 | start() -> 84 | application:start(lhttpc). 85 | 86 | stop() -> 87 | application:stop(lhttpc). 88 | 89 | %% @doc Sends a request with a body. 90 | %% Would be the same as calling 91 | %% `request(Method, URL, Hdrs, Body, [])', that is {@link request/5} 92 | %% with no options. 93 | %% @end 94 | %% @see request/5 95 | request(Method, URL, Hdrs, Body, Opts) -> 96 | {[TO, SO], Rest} = proplists:split(Opts, [timeout, socket_options]), 97 | TimeOut = proplists:get_value(timeout, TO, infinity), 98 | SockOpt = proplists:get_value(socket_options, SO, []), 99 | Options = [{connect_options, SockOpt} | Rest], 100 | Result = lhttpc:request(URL, Method, Hdrs, Body, TimeOut, Options), 101 | case Result of 102 | {ok, {{Status, _Reason}, Headers, Response}} -> 103 | {ok, Status, Headers, (Response)}; 104 | {error, Reason} -> {error, Reason} 105 | end. 106 | 107 | get_pool_size() -> 108 | Opts = proplists:get_value(lhttpc_manager, lhttpc_manager:list_pools()), 109 | proplists:get_value(max_pool_size,Opts). 110 | 111 | set_pool_size(Size) -> 112 | lhttpc_manager:set_max_pool_size(lhttpc_manager, Size). 113 | 114 | -else. 115 | 116 | start() -> 117 | application:start(inets). 118 | 119 | stop() -> 120 | application:stop(inets). 121 | 122 | to_list(Str) when is_binary(Str) -> 123 | binary_to_list(Str); 124 | to_list(Str) -> 125 | Str. 126 | 127 | %% @doc Sends a request with a body. 128 | %% Would be the same as calling 129 | %% `request(Method, URL, Hdrs, Body, [])', that is {@link request/5} 130 | %% with no options. 131 | %% @end 132 | %% @see request/5 133 | -spec request(atom(), string(), headers(), string(), options()) -> result(). 134 | request(Method, URLRaw, HdrsRaw, Body, Opts) -> 135 | Hdrs = lists:map(fun({N, V}) -> 136 | {to_list(N), to_list(V)} 137 | end, HdrsRaw), 138 | URL = to_list(URLRaw), 139 | 140 | Request = case Method of 141 | get -> {URL, Hdrs}; 142 | head -> {URL, Hdrs}; 143 | delete -> {URL, Hdrs}; 144 | _ -> % post, etc. 145 | {URL, Hdrs, 146 | to_list(proplists:get_value(<<"content-type">>, HdrsRaw, [])), 147 | Body} 148 | end, 149 | Options = case proplists:get_value(timeout, Opts, 150 | infinity) 151 | of 152 | infinity -> proplists:delete(timeout, Opts); 153 | _ -> Opts 154 | end, 155 | case httpc:request(Method, Request, Options, []) of 156 | {ok, {{_, Status, _}, Headers, Response}} -> 157 | {ok, Status, Headers, Response}; 158 | {error, Reason} -> {error, Reason} 159 | end. 160 | 161 | get_pool_size() -> 162 | {ok, Size} = httpc:get_option(max_sessions), 163 | Size. 164 | 165 | set_pool_size(Size) -> 166 | httpc:set_option(max_sessions, Size). 167 | 168 | -endif. 169 | 170 | -endif. 171 | 172 | %% @doc Sends a GET request. 173 | %% Would be the same as calling `request(get, URL, [])', 174 | %% that is {@link request/3} with an empty header list. 175 | %% @end 176 | %% @see request/3 177 | -spec get(string()) -> result(). 178 | get(URL) -> request(get, URL, []). 179 | 180 | %% @doc Sends a GET request. 181 | %% Would be the same as calling `request(get, URL, Hdrs)'. 182 | %% @end 183 | %% @see request/3 184 | -spec get(string(), headers()) -> result(). 185 | get(URL, Hdrs) -> request(get, URL, Hdrs). 186 | 187 | %% @doc Sends a POST request with form data. 188 | %% Would be the same as calling 189 | %% `request(post, URL, [{"content-type", "x-www-form-urlencoded"}], Body)'. 190 | %% @end 191 | %% @see request/4 192 | -spec post(string(), string()) -> result(). 193 | post(URL, Body) -> 194 | request(post, URL, 195 | [{"content-type", "x-www-form-urlencoded"}], 196 | Body). 197 | 198 | %% @doc Sends a POST request. 199 | %% Would be the same as calling 200 | %% `request(post, URL, Hdrs, Body)'. 201 | %% @end 202 | %% @see request/4 203 | -spec post(string(), headers(), string()) -> result(). 204 | post(URL, Hdrs, Body) -> 205 | NewHdrs = case [X 206 | || {X, _} <- Hdrs, 207 | to_lower(X) == <<"content-type">>] 208 | of 209 | [] -> 210 | [{<<"content-type">>, <<"x-www-form-urlencoded">>} 211 | | Hdrs]; 212 | _ -> Hdrs 213 | end, 214 | request(post, URL, NewHdrs, Body). 215 | 216 | %% This function is copied from ejabberd's str.erl: 217 | -spec to_lower(binary()) -> binary(); 218 | (char()) -> char(). 219 | 220 | to_lower(B) when is_binary(B) -> 221 | iolist_to_binary(string:to_lower(binary_to_list(B))); 222 | to_lower(C) -> 223 | string:to_lower(C). 224 | 225 | %% @doc Sends a request without a body. 226 | %% Would be the same as calling `request(Method, URL, Hdrs, [], [])', 227 | %% that is {@link request/5} with an empty body. 228 | %% @end 229 | %% @see request/5 230 | -spec request(atom(), string(), headers()) -> result(). 231 | request(Method, URL, Hdrs) -> 232 | request(Method, URL, Hdrs, [], []). 233 | 234 | %% @doc Sends a request with a body. 235 | %% Would be the same as calling 236 | %% `request(Method, URL, Hdrs, Body, [])', that is {@link request/5} 237 | %% with no options. 238 | %% @end 239 | %% @see request/5 240 | -spec request(atom(), string(), headers(), string()) -> result(). 241 | request(Method, URL, Hdrs, Body) -> 242 | request(Method, URL, Hdrs, Body, []). 243 | 244 | % ibrowse {response_format, response_format()} | 245 | % Options - [option()] 246 | % Option - {sync, boolean()} | {stream, StreamTo} | {body_format, body_format()} | {full_result, 247 | % boolean()} | {headers_as_is, boolean()} 248 | %body_format() = string() | binary() 249 | % The body_format option is only valid for the synchronous request and the default is string. 250 | % When making an asynchronous request the body will always be received as a binary. 251 | % lhttpc: always binary 252 | 253 | -------------------------------------------------------------------------------- /src/p1_nif_utils.erl: -------------------------------------------------------------------------------- 1 | %%%------------------------------------------------------------------- 2 | %%% File : p1_nif_utils.erl 3 | %%% Author : Paweł Chmielowski 4 | %%% Description : Helper utilities for handling nif code 5 | %%% 6 | %%% Created : 7 Oct 2015 by Paweł Chmielowski 7 | %%% 8 | %%% 9 | %%% Copyright (C) 2002-2025 ProcessOne, SARL. All Rights Reserved. 10 | %%% 11 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 12 | %%% you may not use this file except in compliance with the License. 13 | %%% You may obtain a copy of the License at 14 | %%% 15 | %%% http://www.apache.org/licenses/LICENSE-2.0 16 | %%% 17 | %%% Unless required by applicable law or agreed to in writing, software 18 | %%% distributed under the License is distributed on an "AS IS" BASIS, 19 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 20 | %%% See the License for the specific language governing permissions and 21 | %%% limitations under the License. 22 | %%% 23 | %%%------------------------------------------------------------------- 24 | -module(p1_nif_utils). 25 | 26 | -export([get_so_path/3]). 27 | 28 | get_so_path(ModuleName, AppNames, SoName) -> 29 | PrivDir = first_match(fun(App) -> 30 | case code:priv_dir(App) of 31 | {error, _} -> none; 32 | V -> V 33 | end 34 | end, AppNames), 35 | case PrivDir of 36 | none -> 37 | Ext = case os:type() of 38 | {win32, _} -> ".dll"; 39 | _ -> ".so" 40 | end, 41 | SoFName = filename:join(["priv", "lib", SoName ++ Ext]), 42 | LPath = first_match(fun(Path) -> 43 | P = case filename:basename(Path) of 44 | "ebin" -> filename:dirname(Path); 45 | _ -> Path 46 | end, 47 | case filelib:is_file(filename:join([P, SoFName])) of 48 | true -> 49 | filename:join([P, "priv", "lib", SoName]); 50 | _ -> 51 | none 52 | end 53 | end, code:get_path()), 54 | case LPath of 55 | none -> 56 | EbinDir = filename:dirname(code:which(ModuleName)), 57 | AppDir = filename:dirname(EbinDir), 58 | filename:join([AppDir, "priv", "lib", SoName]); 59 | Val -> 60 | Val 61 | end; 62 | V -> 63 | filename:join([V, "lib", SoName]) 64 | end. 65 | 66 | first_match(_Fun, []) -> 67 | none; 68 | first_match(Fun, [H|T]) -> 69 | case Fun(H) of 70 | none -> 71 | first_match(Fun, T); 72 | V -> 73 | V 74 | end. 75 | -------------------------------------------------------------------------------- /src/p1_options.erl: -------------------------------------------------------------------------------- 1 | %%%------------------------------------------------------------------- 2 | %%% @author Evgeny Khramtsov 3 | %%% 4 | %%% 5 | %%% Copyright (C) 2002-2025 ProcessOne, SARL. All Rights Reserved. 6 | %%% 7 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 8 | %%% you may not use this file except in compliance with the License. 9 | %%% You may obtain a copy of the License at 10 | %%% 11 | %%% http://www.apache.org/licenses/LICENSE-2.0 12 | %%% 13 | %%% Unless required by applicable law or agreed to in writing, software 14 | %%% distributed under the License is distributed on an "AS IS" BASIS, 15 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | %%% See the License for the specific language governing permissions and 17 | %%% limitations under the License. 18 | %%% 19 | %%%------------------------------------------------------------------- 20 | -module(p1_options). 21 | 22 | -behaviour(gen_server). 23 | 24 | %% API 25 | -export([start/1, start_link/1, insert/4, delete/3, lookup/3, clear/1, 26 | compile/1]). 27 | %% For debug only 28 | -export([dump/1]). 29 | 30 | %% gen_server callbacks 31 | -export([init/1, handle_call/3, handle_cast/2, handle_info/2, 32 | terminate/2, code_change/3]). 33 | 34 | -type scope() :: global | any(). 35 | -record(state, {tab :: atom()}). 36 | 37 | %%%=================================================================== 38 | %%% API 39 | %%%=================================================================== 40 | -spec start(atom()) -> ok | {error, already_started | any()}. 41 | start(Tab) -> 42 | case whereis(Tab) of 43 | undefined -> 44 | application:ensure_all_started(p1_utils), 45 | Spec = {?MODULE, {?MODULE, start_link, [Tab]}, 46 | permanent, 5000, worker, [?MODULE]}, 47 | case supervisor:start_child(p1_utils_sup, Spec) of 48 | {ok, _} -> ok; 49 | {error, {already_started, _}} -> {error, already_started}; 50 | {error, _} = Err -> Err 51 | end; 52 | _ -> 53 | {error, already_started} 54 | end. 55 | 56 | -spec start_link(atom()) -> {ok, pid()} | {error, any()}. 57 | start_link(Tab) -> 58 | gen_server:start_link({local, Tab}, ?MODULE, [Tab], []). 59 | 60 | -spec insert(atom(), atom(), scope(), any()) -> ok. 61 | insert(Tab, Opt, Scope, Val) -> 62 | ets:insert(Tab, {{Opt, Scope}, Val}), 63 | ok. 64 | 65 | -spec delete(atom(), atom(), scope()) -> ok. 66 | delete(Tab, Opt, Scope) -> 67 | ets:delete(Tab, {Opt, Scope}), 68 | ok. 69 | 70 | -spec lookup(atom(), atom(), scope()) -> {ok, any()} | undefined. 71 | lookup(Tab, Opt, Scope) -> 72 | case ets:lookup(Tab, {Opt, Scope}) of 73 | [] -> undefined; 74 | [{_, Val}] -> {ok, Val} 75 | end. 76 | 77 | -spec clear(atom()) -> ok. 78 | clear(Tab) -> 79 | ets:delete_all_objects(Tab), 80 | ok. 81 | 82 | -spec compile(atom()) -> ok. 83 | compile(Tab) -> 84 | case gen_server:call(Tab, compile, timer:minutes(1)) of 85 | ok -> ok; 86 | {error, Reason} -> 87 | error_logger:error_msg( 88 | "Failed to compile configuration for ~p: ~s", 89 | [Tab, format_error(Reason)]), 90 | erlang:error({compile_failed, Tab}) 91 | end. 92 | 93 | -spec dump(atom()) -> ok. 94 | dump(Mod) -> 95 | Exprs = get_exprs(Mod), 96 | File = filename:join("/tmp", atom_to_list(Mod) ++ ".erl"), 97 | case file:write_file(File, string:join(Exprs, io_lib:nl())) of 98 | ok -> 99 | %% erl_tidy:file(File, [{backups, false}]), 100 | io:format("Dynamic module '~s' is written to ~ts~n", [Mod, File]); 101 | {error, Reason} -> 102 | io:format("Failed to dump dynamic module '~s' to ~ts: ~s~n", 103 | [Mod, File, file:format_error(Reason)]) 104 | end. 105 | 106 | %%%=================================================================== 107 | %%% gen_server callbacks 108 | %%%=================================================================== 109 | init([Tab]) -> 110 | catch ets:new(Tab, [named_table, public, {read_concurrency, true}]), 111 | {ok, #state{tab = Tab}}. 112 | 113 | handle_call(compile, From, #state{tab = Tab} = State) -> 114 | do_compile(Tab, [From]), 115 | {noreply, State}; 116 | handle_call(_Request, _From, State) -> 117 | {noreply, State}. 118 | 119 | handle_cast(_Msg, State) -> 120 | {noreply, State}. 121 | 122 | handle_info(_Info, State) -> 123 | {noreply, State}. 124 | 125 | terminate(_Reason, _State) -> 126 | ok. 127 | 128 | code_change(_OldVsn, State, _Extra) -> 129 | {ok, State}. 130 | 131 | %%%=================================================================== 132 | %%% Internal functions 133 | %%%=================================================================== 134 | -spec do_compile(atom(), list()) -> ok. 135 | do_compile(Tab, Callers) -> 136 | receive 137 | {'gen_call', Caller, compile} -> 138 | do_compile(Tab, [Caller|Callers]) 139 | after 0 -> 140 | Exprs = get_exprs(Tab), 141 | Result = compile_exprs(Tab, Exprs), 142 | lists:foreach( 143 | fun(Caller) -> 144 | gen_server:reply(Caller, Result) 145 | end, lists:reverse(Callers)) 146 | end. 147 | 148 | -spec get_exprs(atom()) -> [string()]. 149 | get_exprs(Mod) -> 150 | OptMap = ets:foldl( 151 | fun({{Opt, Scope}, Val}, Acc) -> 152 | Vals = maps:get(Opt, Acc, []), 153 | maps:put(Opt, [{Scope, Val}|Vals], Acc) 154 | end, #{}, Mod), 155 | Opts = maps:fold( 156 | fun(Opt, Vals, Acc) -> 157 | Default = case lists:keyfind(global, 1, Vals) of 158 | {_, V} -> {ok, V}; 159 | false -> undefined 160 | end, 161 | [lists:flatmap( 162 | fun({Scope, Val}) when {ok, Val} /= Default -> 163 | io_lib:format( 164 | "~p(~p) -> {ok, ~p};~n", [Opt, Scope, Val]); 165 | (_) -> 166 | "" 167 | end, Vals) ++ io_lib:format("~p(_) -> ~p.", [Opt, Default]) 168 | |Acc] 169 | end, [], OptMap), 170 | Known = maps:fold( 171 | fun(Opt, _, Acc) -> 172 | io_lib:format( 173 | "is_known(~p) -> true;~n", [Opt]) ++ Acc 174 | end, "", OptMap) ++ "is_known(_) -> false.", 175 | Scopes = maps:fold( 176 | fun(Opt, Vals, Acc) -> 177 | io_lib:format( 178 | "get_scope(~p) -> ~p;~n", 179 | [Opt, [Scope || {Scope, _} <- Vals]]) ++ Acc 180 | end, "", OptMap) ++ "get_scope(_) -> [].", 181 | [io_lib:format("-module(~p).", [Mod]), 182 | "-compile(export_all).", 183 | Known, Scopes | Opts]. 184 | 185 | -spec compile_exprs(module(), [string()]) -> ok | {error, any()}. 186 | compile_exprs(Mod, Exprs) -> 187 | try 188 | Forms = lists:map( 189 | fun(Expr) -> 190 | {ok, Tokens, _} = erl_scan:string(lists:flatten(Expr)), 191 | {ok, Form} = erl_parse:parse_form(Tokens), 192 | Form 193 | end, Exprs), 194 | {ok, Code} = case compile:forms(Forms, []) of 195 | {ok, Mod, Bin} -> {ok, Bin}; 196 | {ok, Mod, Bin, _Warnings} -> {ok, Bin}; 197 | Error -> Error 198 | end, 199 | {module, Mod} = code:load_binary(Mod, "nofile", Code), 200 | ok 201 | catch _:{badmatch, {error, ErrInfo, _ErrLocation}} -> 202 | {error, ErrInfo}; 203 | _:{badmatch, {error, _} = Err} -> 204 | Err; 205 | _:{badmatch, error} -> 206 | {error, compile_failed} 207 | end. 208 | 209 | format_error({_Line, _Mod, _Term} = Reason) -> 210 | "Syntax error at line " ++ file:format_error(Reason); 211 | format_error(Reason) -> 212 | atom_to_list(Reason). 213 | -------------------------------------------------------------------------------- /src/p1_prof.erl: -------------------------------------------------------------------------------- 1 | %%%------------------------------------------------------------------- 2 | %%% File : p1_prof.erl 3 | %%% Author : Evgeniy Khramtsov 4 | %%% Description : Handy wrapper around eprof and fprof 5 | %%% 6 | %%% Created : 23 Jan 2010 by Evgeniy Khramtsov 7 | %%% 8 | %%% 9 | %%% ejabberd, Copyright (C) 2002-2025 ProcessOne 10 | %%% 11 | %%% This program is free software; you can redistribute it and/or 12 | %%% modify it under the terms of the GNU General Public License as 13 | %%% published by the Free Software Foundation; either version 2 of the 14 | %%% License, or (at your option) any later version. 15 | %%% 16 | %%% This program is distributed in the hope that it will be useful, 17 | %%% but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | %%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | %%% General Public License for more details. 20 | %%% 21 | %%% You should have received a copy of the GNU General Public License along 22 | %%% with this program; if not, write to the Free Software Foundation, Inc., 23 | %%% 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 24 | %%% 25 | %%%------------------------------------------------------------------- 26 | -module(p1_prof). 27 | 28 | %% API 29 | -export([eprof_start/0, eprof_stop/0, 30 | eprof_start/1, fprof_apply/3, 31 | fprof_start/0, fprof_start/1, 32 | fprof_stop/0, fprof_analyze/0, 33 | queue/0, queue/1, memory/0, memory/1, 34 | reds/0, reds/1, trace/1, help/0, 35 | q/0, m/0, r/0, q/1, m/1, r/1, 36 | locks/0, locks/1]). 37 | 38 | -define(TRACE_FILE, "/tmp/fprof.trace"). 39 | -define(ANALYSIS_FILE, "/tmp/fprof.analysis"). 40 | 41 | %%==================================================================== 42 | %% API 43 | %%==================================================================== 44 | eprof_start() -> 45 | eprof_start(get_procs()). 46 | 47 | eprof_start(Duration) when is_integer(Duration) -> 48 | eprof_start(get_procs()), 49 | timer:sleep(timer:seconds(Duration)), 50 | eprof_stop(); 51 | eprof_start([]) -> 52 | {error, no_procs_found}; 53 | eprof_start(Procs) -> 54 | eprof:start(), 55 | eprof:start_profiling(Procs). 56 | 57 | fprof_apply(M, F, A) -> 58 | fprof:apply(M, F, A, [{file, ?TRACE_FILE}]), 59 | fprof_analyze(). 60 | 61 | fprof_start() -> 62 | fprof_start(0). 63 | 64 | fprof_start(Duration) -> 65 | case get_procs() of 66 | [] -> 67 | {error, no_procs_found}; 68 | Procs -> 69 | case fprof:trace([start, {procs, Procs}, {file, ?TRACE_FILE}]) of 70 | ok -> 71 | io:format("Profiling started, writing trace data to ~s~n", 72 | [?TRACE_FILE]), 73 | if Duration > 0 -> 74 | timer:sleep(Duration*1000), 75 | fprof:trace([stop]), 76 | fprof:stop(); 77 | true-> 78 | ok 79 | end; 80 | Err -> 81 | io:format("Couldn't start profiling: ~p~n", [Err]), 82 | Err 83 | end 84 | end. 85 | 86 | fprof_stop() -> 87 | fprof:trace([stop]), 88 | case fprof:profile([{file, ?TRACE_FILE}]) of 89 | ok -> 90 | case fprof:analyse([totals, no_details, {sort, own}, 91 | no_callers, {dest, ?ANALYSIS_FILE}]) of 92 | ok -> 93 | fprof:stop(), 94 | format_fprof_analyze(); 95 | Err -> 96 | io:format("Couldn't analyze: ~p~n", [Err]), 97 | Err 98 | end; 99 | Err -> 100 | io:format("Couldn't compile a trace into profile data: ~p~n", 101 | [Err]), 102 | Err 103 | end. 104 | 105 | fprof_analyze() -> 106 | fprof_stop(). 107 | 108 | eprof_stop() -> 109 | eprof:stop_profiling(), 110 | eprof:analyze(total). 111 | 112 | help() -> 113 | M = ?MODULE, 114 | io:format("Brief help:~n" 115 | "~p:queue(N) - show top N pids sorted by queue length~n" 116 | "~p:queue() - shorthand for ~p:queue(10)~n" 117 | "~p:memory(N) - show top N pids sorted by memory usage~n" 118 | "~p:memory() - shorthand for ~p:memory(10)~n" 119 | "~p:reds(N) - show top N pids sorted by reductions~n" 120 | "~p:reds() - shorthand for ~p:reds(10)~n" 121 | "~p:q(N)|~p:q() - same as ~p:queue(N)|~p:queue()~n" 122 | "~p:m(N)|~p:m() - same as ~p:memory(N)|~p:memory()~n" 123 | "~p:r(N)|~p:r() - same as ~p:reds(N)|~p:reds()~n" 124 | "~p:trace(Pid) - trace Pid; to stop tracing close " 125 | "Erlang shell with Ctrl+C~n" 126 | "~p:eprof_start() - start eprof on all available pids; " 127 | "DO NOT use on production system!~n" 128 | "~p:eprof_stop() - stop eprof and print result~n" 129 | "~p:fprof_start() - start fprof on all available pids; " 130 | "DO NOT use on production system!~n" 131 | "~p:fprof_stop() - stop eprof and print formatted result~n" 132 | "~p:fprof_start(N) - start and run fprof for N seconds; " 133 | "use ~p:fprof_analyze() to analyze collected statistics and " 134 | "print formatted result; use on production system with CARE~n" 135 | "~p:fprof_analyze() - analyze previously collected statistics " 136 | "using ~p:fprof_start(N) and print formatted result~n" 137 | "~p:help() - print this help~n", 138 | lists:duplicate(31, M)). 139 | 140 | q() -> 141 | queue(). 142 | 143 | q(N) -> 144 | queue(N). 145 | 146 | m() -> 147 | memory(). 148 | 149 | m(N) -> 150 | memory(N). 151 | 152 | r() -> 153 | reds(). 154 | 155 | r(N) -> 156 | reds(N). 157 | 158 | queue() -> 159 | queue(10). 160 | 161 | memory() -> 162 | memory(10). 163 | 164 | reds() -> 165 | reds(10). 166 | 167 | queue(N) -> 168 | dump(N, lists:reverse(lists:ukeysort(1, all_pids(queue)))). 169 | 170 | memory(N) -> 171 | dump(N, lists:reverse(lists:ukeysort(2, all_pids(memory)))). 172 | 173 | reds(N) -> 174 | dump(N, lists:reverse(lists:ukeysort(3, all_pids(reductions)))). 175 | 176 | trace(Pid) -> 177 | erlang:trace(Pid, true, [send, 'receive']), 178 | trace_loop(). 179 | 180 | trace_loop() -> 181 | receive 182 | M -> 183 | io:format("~p~n", [M]), 184 | trace_loop() 185 | end. 186 | 187 | %%==================================================================== 188 | %% Internal functions 189 | %%==================================================================== 190 | get_procs() -> 191 | processes(). 192 | 193 | format_fprof_analyze() -> 194 | case file:consult(?ANALYSIS_FILE) of 195 | {ok, [_, [{totals, _, _, TotalOWN}] | Rest]} -> 196 | OWNs = lists:flatmap( 197 | fun({MFA, _, _, OWN}) -> 198 | Percent = OWN*100/TotalOWN, 199 | case round(Percent) of 200 | 0 -> 201 | []; 202 | _ -> 203 | [{mfa_to_list(MFA), Percent}] 204 | end 205 | end, Rest), 206 | ACCs = collect_accs(Rest), 207 | MaxACC = find_max(ACCs), 208 | MaxOWN = find_max(OWNs), 209 | io:format("=== Sorted by OWN:~n"), 210 | lists:foreach( 211 | fun({MFA, Per}) -> 212 | L = length(MFA), 213 | S = lists:duplicate(MaxOWN - L + 2, $ ), 214 | io:format("~s~s~.2f%~n", [MFA, S, Per]) 215 | end, lists:reverse(lists:keysort(2, OWNs))), 216 | io:format("~n=== Sorted by ACC:~n"), 217 | lists:foreach( 218 | fun({MFA, Per}) -> 219 | L = length(MFA), 220 | S = lists:duplicate(MaxACC - L + 2, $ ), 221 | io:format("~s~s~.2f%~n", [MFA, S, Per]) 222 | end, lists:reverse(lists:keysort(2, ACCs))); 223 | Err -> 224 | Err 225 | end. 226 | 227 | mfa_to_list({M, F, A}) -> 228 | atom_to_list(M) ++ ":" ++ atom_to_list(F) ++ "/" ++ integer_to_list(A); 229 | mfa_to_list(F) when is_atom(F) -> 230 | atom_to_list(F). 231 | 232 | find_max(List) -> 233 | find_max(List, 0). 234 | 235 | find_max([{V, _}|Tail], Acc) -> 236 | find_max(Tail, lists:max([length(V), Acc])); 237 | find_max([], Acc) -> 238 | Acc. 239 | 240 | collect_accs(List) -> 241 | List1 = lists:filter( 242 | fun({MFA, _, _, _}) -> 243 | case MFA of 244 | {sys, _, _} -> 245 | false; 246 | suspend -> 247 | false; 248 | {gen_fsm, _, _} -> 249 | false; 250 | {p1_fsm, _, _} -> 251 | false; 252 | {gen, _, _} -> 253 | false; 254 | {gen_server, _, _} -> 255 | false; 256 | {proc_lib, _, _} -> 257 | false; 258 | _ -> 259 | true 260 | end 261 | end, List), 262 | TotalACC = lists:sum([A || {_, _, A, _} <- List1]), 263 | lists:flatmap( 264 | fun({MFA, _, ACC, _}) -> 265 | Percent = ACC*100/TotalACC, 266 | case round(Percent) of 267 | 0 -> 268 | []; 269 | _ -> 270 | [{mfa_to_list(MFA), Percent}] 271 | end 272 | end, List1). 273 | 274 | all_pids(Type) -> 275 | lists:foldl( 276 | fun(P, Acc) when P == self() -> 277 | %% exclude ourself from statistics 278 | Acc; 279 | (P, Acc) -> 280 | case catch process_info( 281 | P, 282 | [message_queue_len, 283 | status, 284 | memory, 285 | reductions, 286 | dictionary, 287 | current_function, 288 | registered_name]) of 289 | [{_, QLen}, {_, Status}, {_, Memory}, {_, Reds}, 290 | {_, Dict}, {_, CurFun}, {_, RegName}] -> 291 | Dict1 = filter_dict(Dict, RegName), 292 | {IntQLen, Dict2} = 293 | case lists:keytake('$internal_queue_len', 1, Dict1) of 294 | {value, {_, N}, D} -> 295 | {N, D}; 296 | false -> 297 | {0, Dict1} 298 | end, 299 | Len = QLen + IntQLen, 300 | if Type == queue andalso Len == 0 -> 301 | Acc; 302 | true -> 303 | Dict3 = [{message_queue_len, Len}, 304 | {status, Status}, 305 | {memory, Memory}, 306 | {reductions, Reds}, 307 | {current_function, CurFun}, 308 | {registered_name, RegName}|Dict2], 309 | [{Len, Memory, Reds, P, Dict3}|Acc] 310 | end; 311 | _ -> 312 | Acc 313 | end 314 | end, [], processes()). 315 | 316 | dump(N, Rs) -> 317 | lists:foreach( 318 | fun({_, _, _, Pid, Properties}) -> 319 | PidStr = pid_to_list(Pid), 320 | [_, Maj, Min] = string:tokens( 321 | string:substr( 322 | PidStr, 2, length(PidStr) - 2), "."), 323 | io:put_chars( 324 | [io_lib:format("** pid: pid(0,~s,~s)~n", [Maj, Min]), 325 | [io_lib:format("** ~s: ~p~n", [Key, Val]) 326 | || {Key, Val} <- Properties], io_lib:nl()]) 327 | end, nthhead(N, Rs)). 328 | 329 | nthhead(N, L) -> 330 | lists:reverse(nthhead(N, L, [])). 331 | 332 | nthhead(0, _L, Acc) -> 333 | Acc; 334 | nthhead(N, [H|T], Acc) -> 335 | nthhead(N-1, T, [H|Acc]); 336 | nthhead(_N, [], Acc) -> 337 | Acc. 338 | 339 | filter_dict(Dict, RegName) -> 340 | lists:filter( 341 | fun({'$internal_queue_len', _}) -> true; 342 | ({'$initial_call', _}) -> RegName == []; 343 | ({'$ancestors', _}) -> RegName == []; 344 | (_) -> false 345 | end, Dict). 346 | 347 | % output in the console counts of locks, optionally waiting for few seconds before collect 348 | locks() -> 349 | locks(5). 350 | locks(Time) -> 351 | lcnt:rt_opt({copy_save, true}), 352 | lcnt:start(), 353 | lcnt:clear(), 354 | timer:sleep(Time*1000), 355 | lcnt:collect(), 356 | lcnt:conflicts(), 357 | lcnt:stop(), 358 | lcnt:rt_opt({copy_save, false}), 359 | ok. 360 | -------------------------------------------------------------------------------- /src/p1_proxy_protocol.erl: -------------------------------------------------------------------------------- 1 | %%%---------------------------------------------------------------------- 2 | %%% File : p1_proxy_protocol.erl 3 | %%% Author : Paweł Chmielowski 4 | %%% Purpose : 5 | %%% Created : 27 Nov 2018 by Paweł Chmielowski 6 | %%% 7 | %%% 8 | %%% Copyright (C) 2002-2025 ProcessOne, SARL. All Rights Reserved. 9 | %%% 10 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 11 | %%% you may not use this file except in compliance with the License. 12 | %%% You may obtain a copy of the License at 13 | %%% 14 | %%% http://www.apache.org/licenses/LICENSE-2.0 15 | %%% 16 | %%% Unless required by applicable law or agreed to in writing, software 17 | %%% distributed under the License is distributed on an "AS IS" BASIS, 18 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 19 | %%% See the License for the specific language governing permissions and 20 | %%% limitations under the License. 21 | %%% 22 | %%%---------------------------------------------------------------------- 23 | -module(p1_proxy_protocol). 24 | -author("pawel@process-one.net"). 25 | 26 | %% API 27 | -export([decode/3]). 28 | 29 | -spec decode(gen_tcp | ssl, inet:socket(), integer()) 30 | -> {{inet:ip_address(), inet:port_number()}, 31 | {inet:ip_address(), inet:port_number()}} 32 | | {error, atom()} 33 | | {undefined, undefined}. 34 | decode(SockMod, Socket, Timeout) -> 35 | V = SockMod:recv(Socket, 6, Timeout), 36 | case V of 37 | {ok, <<"PROXY ">>} -> 38 | decode_v1(SockMod, Socket, Timeout); 39 | {ok, <<16#0d, 16#0a, 16#0d, 16#0a, 16#00, 16#0d>>} -> 40 | decode_v2(SockMod, Socket, Timeout); 41 | _ -> 42 | {error, eproto} 43 | end. 44 | 45 | decode_v1(SockMod, Socket, Timeout) -> 46 | case read_until_rn(SockMod, Socket, <<>>, false, Timeout) of 47 | {error, _} = Err -> 48 | Err; 49 | Val -> 50 | case binary:split(Val, <<" ">>, [global]) of 51 | [<<"TCP4">>, SAddr, DAddr, SPort, DPort] -> 52 | try {inet_parse:ipv4strict_address(binary_to_list(SAddr)), 53 | inet_parse:ipv4strict_address(binary_to_list(DAddr)), 54 | binary_to_integer(SPort), 55 | binary_to_integer(DPort)} 56 | of 57 | {{ok, DA}, {ok, SA}, DP, SP} -> 58 | {{SA, SP}, {DA, DP}}; 59 | _ -> 60 | {error, eproto} 61 | catch 62 | error:badarg -> 63 | {error, eproto} 64 | end; 65 | [<<"TCP6">>, SAddr, DAddr, SPort, DPort] -> 66 | try {inet_parse:ipv6strict_address(binary_to_list(SAddr)), 67 | inet_parse:ipv6strict_address(binary_to_list(DAddr)), 68 | binary_to_integer(SPort), 69 | binary_to_integer(DPort)} 70 | of 71 | {{ok, DA}, {ok, SA}, DP, SP} -> 72 | {{SA, SP}, {DA, DP}}; 73 | _ -> 74 | {error, eproto} 75 | catch 76 | error:badarg -> 77 | {error, eproto} 78 | end; 79 | [<<"UNKNOWN">> | _] -> 80 | {undefined, undefined} 81 | end 82 | end. 83 | 84 | decode_v2(SockMod, Socket, Timeout) -> 85 | case SockMod:recv(Socket, 10, Timeout) of 86 | {error, _} = Err -> 87 | Err; 88 | {ok, <<16#0a, 16#51, 16#55, 16#49, 16#54, 16#0a, 89 | 2:4, Command:4, Transport:8, AddrLen:16/big-unsigned-integer>>} -> 90 | case SockMod:recv(Socket, AddrLen, Timeout) of 91 | {error, _} = Err -> 92 | Err; 93 | {ok, Data} -> 94 | case Command of 95 | 0 -> 96 | case {inet:sockname(Socket), inet:peername(Socket)} of 97 | {{ok, SA}, {ok, DA}} -> 98 | {SA, DA}; 99 | {{error, _} = E, _} -> 100 | E; 101 | {_, {error, _} = E} -> 102 | E 103 | end; 104 | 1 -> 105 | case Transport of 106 | % UNSPEC or UNIX 107 | V when V == 0; V == 16#31; V == 16#32 -> 108 | {{unknown, unknown}, {unknown, unknown}}; 109 | % IPV4 over TCP or UDP 110 | V when V == 16#11; V == 16#12 -> 111 | case Data of 112 | <> -> 117 | {{{S1, S2, S3, S4}, SP}, 118 | {{D1, D2, D3, D4}, DP}}; 119 | _ -> 120 | {error, eproto} 121 | end; 122 | % IPV6 over TCP or UDP 123 | V when V == 16#21; V == 16#22 -> 124 | case Data of 125 | <> -> 144 | {{{S1, S2, S3, S4, S5, S6, S7, S8}, SP}, 145 | {{D1, D2, D3, D4, D5, D6, D7, D8}, DP}}; 146 | _ -> 147 | {error, eproto} 148 | end 149 | end; 150 | _ -> 151 | {error, eproto} 152 | end 153 | end; 154 | <<16#0a, 16#51, 16#55, 16#49, 16#54, 16#0a, _/binary>> -> 155 | {error, eproto}; 156 | _ -> 157 | {error, eproto} 158 | end. 159 | 160 | read_until_rn(_SockMod, _Socket, Data, _, _) when size(Data) > 107 -> 161 | {error, eproto}; 162 | read_until_rn(SockMod, Socket, Data, true, Timeout) -> 163 | case SockMod:recv(Socket, 1, Timeout) of 164 | {ok, <<"\n">>} -> 165 | Data; 166 | {ok, <<"\r">>} -> 167 | read_until_rn(SockMod, Socket, <>, 168 | true, Timeout); 169 | {ok, Other} -> 170 | read_until_rn(SockMod, Socket, <>, 171 | false, Timeout); 172 | {error, _} = Err -> 173 | Err 174 | end; 175 | read_until_rn(SockMod, Socket, Data, false, Timeout) -> 176 | case SockMod:recv(Socket, 2, Timeout) of 177 | {ok, <<"\r\n">>} -> 178 | Data; 179 | {ok, <>} -> 180 | read_until_rn(SockMod, Socket, <>, 181 | true, Timeout); 182 | {ok, Other} -> 183 | read_until_rn(SockMod, Socket, <>, 184 | false, Timeout); 185 | {error, _} = Err -> 186 | Err 187 | end. 188 | -------------------------------------------------------------------------------- /src/p1_queue.erl: -------------------------------------------------------------------------------- 1 | %%%------------------------------------------------------------------- 2 | %%% @author Evgeny Khramtsov 3 | %%% @copyright (C) 2017-2025 Evgeny Khramtsov 4 | %%% @doc 5 | %%% 6 | %%% @end 7 | %%% Created : 8 Mar 2017 by Evgeny Khramtsov 8 | %%%------------------------------------------------------------------- 9 | -module(p1_queue). 10 | 11 | %% API 12 | -export([new/0, new/1, new/2, is_queue/1, len/1, is_empty/1, in/2, out/1, 13 | peek/1, drop/1, from_list/1, from_list/2, from_list/3, 14 | to_list/1, clear/1, foreach/2, foldl/3, dropwhile/2, type/1, 15 | format_error/1, ram_to_file/1, file_to_ram/1, get_limit/1, 16 | set_limit/2]). 17 | -export([start/1, stop/0]). 18 | 19 | -type limit() :: non_neg_integer() | unlimited. 20 | -type rqueue() :: rqueue(any()). 21 | -type rqueue(T) :: {queue:queue(T), non_neg_integer(), limit()}. 22 | -type fqueue() :: p1_file_queue:queue(). 23 | -type queue() :: rqueue(any()) | fqueue(). 24 | -type queue(T) :: rqueue(T) | fqueue(). 25 | -type queue_type() :: ram | file. 26 | -type error_reason() :: p1_file_queue:error_reason(). 27 | -export_type([queue/0, queue/1, queue_type/0, error_reason/0]). 28 | 29 | %%%=================================================================== 30 | %%% API 31 | %%%=================================================================== 32 | -spec start(file:filename()) -> ok | {error, any()}. 33 | start(Dir) -> 34 | application:ensure_all_started(p1_utils), 35 | case p1_file_queue:start(Dir) of 36 | {ok, _} -> ok; 37 | {error, {already_started, _}} -> ok; 38 | Err -> Err 39 | end. 40 | 41 | -spec stop() -> ok | {error, any()}. 42 | stop() -> 43 | p1_file_queue:stop(). 44 | 45 | -spec new() -> rqueue(). 46 | new() -> 47 | new(ram). 48 | 49 | -spec new(ram) -> rqueue(); 50 | (file) -> fqueue(). 51 | new(Type) -> 52 | new(Type, unlimited). 53 | 54 | -spec new(ram, limit()) -> rqueue(); 55 | (file, limit()) -> fqueue(). 56 | new(ram, Limit) -> 57 | {queue:new(), 0, Limit}; 58 | new(file, Limit) -> 59 | p1_file_queue:new(Limit). 60 | 61 | -spec type(queue()) -> ram | {file, file:filename()}. 62 | type({_, _, _}) -> 63 | ram; 64 | type(Q) -> 65 | {file, p1_file_queue:path(Q)}. 66 | 67 | -spec is_queue(any()) -> boolean(). 68 | is_queue({Q, Len, _}) when is_integer(Len), Len >= 0 -> 69 | queue:is_queue(Q); 70 | is_queue(Q) -> 71 | p1_file_queue:is_queue(Q). 72 | 73 | -spec len(queue()) -> non_neg_integer(). 74 | len({_, Len, _}) -> 75 | Len; 76 | len(Q) -> 77 | p1_file_queue:len(Q). 78 | 79 | -spec is_empty(queue()) -> boolean(). 80 | is_empty({_, Len, _}) -> 81 | Len == 0; 82 | is_empty(Q) -> 83 | p1_file_queue:is_empty(Q). 84 | 85 | -spec get_limit(queue()) -> limit(). 86 | get_limit({_, _, Limit}) -> 87 | Limit; 88 | get_limit(Q) -> 89 | p1_file_queue:get_limit(Q). 90 | 91 | -spec set_limit(rqueue(T), limit()) -> rqueue(T); 92 | (fqueue(), limit()) -> fqueue(). 93 | set_limit({Q, Len, _}, Limit) -> 94 | {Q, Len, Limit}; 95 | set_limit(Q, Limit) -> 96 | p1_file_queue:set_limit(Q, Limit). 97 | 98 | -spec in(term(), rqueue(T)) -> rqueue(T); 99 | (term(), fqueue()) -> fqueue(). 100 | in(Item, {Q, Len, Limit}) -> 101 | if Len < Limit -> 102 | {queue:in(Item, Q), Len+1, Limit}; 103 | true -> 104 | erlang:error(full) 105 | end; 106 | in(Item, Q) -> 107 | p1_file_queue:in(Item, Q). 108 | 109 | -spec out(rqueue(T)) -> {{value, term()}, rqueue(T)} | {empty, rqueue(T)}; 110 | (fqueue()) -> {{value, term()}, fqueue()} | {empty, fqueue()}. 111 | out({Q, 0, Limit}) -> 112 | {empty, {Q, 0, Limit}}; 113 | out({Q, Len, Limit}) -> 114 | {{value, Item}, Q1} = queue:out(Q), 115 | {{value, Item}, {Q1, Len-1, Limit}}; 116 | out(Q) -> 117 | p1_file_queue:out(Q). 118 | 119 | -spec peek(queue(T)) -> empty | {value, T}. 120 | peek({Q, _, _}) -> 121 | queue:peek(Q); 122 | peek(Q) -> 123 | p1_file_queue:peek(Q). 124 | 125 | -spec drop(rqueue(T)) -> rqueue(T); 126 | (fqueue()) -> fqueue(). 127 | drop({Q, Len, Limit}) -> 128 | {queue:drop(Q), Len-1, Limit}; 129 | drop(Q) -> 130 | p1_file_queue:drop(Q). 131 | 132 | -spec from_list([T]) -> rqueue(T). 133 | from_list(L) -> 134 | from_list(L, ram, unlimited). 135 | 136 | -spec from_list([T], ram) -> rqueue(T); 137 | (list(), file) -> fqueue(). 138 | from_list(L, Type) -> 139 | from_list(L, Type, unlimited). 140 | 141 | -spec from_list([T], ram, limit()) -> rqueue(T); 142 | (list(), file, limit()) -> fqueue(). 143 | from_list(L, ram, Limit) -> 144 | Len = length(L), 145 | if Len =< Limit -> 146 | {queue:from_list(L), Len, Limit}; 147 | true -> 148 | erlang:error(full) 149 | end; 150 | from_list(L, file, Limit) -> 151 | p1_file_queue:from_list(L, Limit). 152 | 153 | -spec to_list(queue(T)) -> [T]. 154 | to_list({Q, _, _}) -> 155 | queue:to_list(Q); 156 | to_list(Q) -> 157 | p1_file_queue:to_list(Q). 158 | 159 | -spec foreach(fun((T) -> term()), queue(T)) -> ok. 160 | foreach(F, {Q, Len, Limit}) -> 161 | case queue:out(Q) of 162 | {{value, Item}, Q1} -> 163 | F(Item), 164 | foreach(F, {Q1, Len-1, Limit}); 165 | {empty, _} -> 166 | ok 167 | end; 168 | foreach(F, Q) -> 169 | p1_file_queue:foreach(F, Q). 170 | 171 | -spec foldl(fun((T1, T2) -> T2), T2, queue(T1)) -> T2. 172 | foldl(F, Acc, {Q, Len, Limit}) -> 173 | case queue:out(Q) of 174 | {{value, Item}, Q1} -> 175 | Acc1 = F(Item, Acc), 176 | foldl(F, Acc1, {Q1, Len-1, Limit}); 177 | {empty, _} -> 178 | Acc 179 | end; 180 | foldl(F, Acc, Q) -> 181 | p1_file_queue:foldl(F, Acc, Q). 182 | 183 | -spec dropwhile(fun((T) -> boolean()), rqueue(T)) -> rqueue(T); 184 | (fun((term()) -> boolean()), fqueue()) -> fqueue(). 185 | dropwhile(_, {_, 0, _} = Q) -> 186 | Q; 187 | dropwhile(F, {Q, Len, Limit}) -> 188 | {value, Item} = queue:peek(Q), 189 | case F(Item) of 190 | true -> 191 | dropwhile(F, {queue:drop(Q), Len-1, Limit}); 192 | _ -> 193 | {Q, Len, Limit} 194 | end; 195 | dropwhile(F, Q) -> 196 | p1_file_queue:dropwhile(F, Q). 197 | 198 | -spec clear(rqueue(T)) -> rqueue(T); 199 | (fqueue()) -> fqueue(). 200 | clear({_, _, Limit}) -> 201 | {queue:new(), 0, Limit}; 202 | clear(Q) -> 203 | p1_file_queue:clear(Q). 204 | 205 | -spec ram_to_file(queue()) -> fqueue(). 206 | ram_to_file({_, _, Limit} = Q) -> 207 | foldl(fun p1_file_queue:in/2, new(file, Limit), Q); 208 | ram_to_file(Q) -> 209 | Q. 210 | 211 | -spec file_to_ram(queue()) -> rqueue(). 212 | file_to_ram({_, _, _} = Q) -> 213 | Q; 214 | file_to_ram(Q) -> 215 | Limit = p1_file_queue:get_limit(Q), 216 | p1_file_queue:foldl(fun in/2, new(ram, Limit), Q). 217 | 218 | -spec format_error(error_reason()) -> string(). 219 | format_error(Reason) -> 220 | p1_file_queue:format_error(Reason). 221 | 222 | %%%=================================================================== 223 | %%% Internal functions 224 | %%%=================================================================== 225 | -------------------------------------------------------------------------------- /src/p1_rand.erl: -------------------------------------------------------------------------------- 1 | %%%---------------------------------------------------------------------- 2 | %%% File : p1_rand.erl 3 | %%% Author : Alexey Shchepin 4 | %%% Purpose : Random generation number wrapper 5 | %%% Created : 13 Dec 2002 by Alexey Shchepin 6 | %%% 7 | %%% 8 | %%% ejabberd, Copyright (C) 2002-2025 ProcessOne 9 | %%% 10 | %%% This program is free software; you can redistribute it and/or 11 | %%% modify it under the terms of the GNU General Public License as 12 | %%% published by the Free Software Foundation; either version 2 of the 13 | %%% License, or (at your option) any later version. 14 | %%% 15 | %%% This program is distributed in the hope that it will be useful, 16 | %%% but WITHOUT ANY WARRANTY; without even the implied warranty of 17 | %%% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 | %%% General Public License for more details. 19 | %%% 20 | %%% You should have received a copy of the GNU General Public License along 21 | %%% with this program; if not, write to the Free Software Foundation, Inc., 22 | %%% 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 23 | %%% 24 | %%%---------------------------------------------------------------------- 25 | 26 | -module(p1_rand). 27 | 28 | -author('alexey@process-one.net'). 29 | 30 | -export([get_string/0, uniform/0, uniform/1, uniform/2, bytes/1, 31 | round_robin/1, get_alphanum_string/1]). 32 | 33 | -define(THRESHOLD, 16#10000000000000000). 34 | 35 | -ifdef(HAVE_RAND). 36 | get_string() -> 37 | R = rand:uniform(?THRESHOLD), 38 | integer_to_binary(R). 39 | 40 | uniform() -> 41 | rand:uniform(). 42 | 43 | uniform(N) -> 44 | rand:uniform(N). 45 | 46 | uniform(N, M) -> 47 | rand:uniform(M-N+1) + N-1. 48 | -else. 49 | get_string() -> 50 | R = crypto:rand_uniform(0, ?THRESHOLD), 51 | integer_to_binary(R). 52 | 53 | uniform() -> 54 | crypto:rand_uniform(0, ?THRESHOLD)/?THRESHOLD. 55 | 56 | uniform(N) -> 57 | crypto:rand_uniform(1, N+1). 58 | 59 | uniform(N, M) -> 60 | crypto:rand_uniform(N, M+1). 61 | -endif. 62 | 63 | -spec bytes(non_neg_integer()) -> binary(). 64 | bytes(N) -> 65 | crypto:strong_rand_bytes(N). 66 | 67 | -spec round_robin(pos_integer()) -> non_neg_integer(). 68 | round_robin(N) -> 69 | p1_time_compat:unique_integer([monotonic, positive]) rem N. 70 | 71 | -spec get_alphanum_string(non_neg_integer()) -> binary(). 72 | get_alphanum_string(Length) -> 73 | list_to_binary(get_alphanum_string([], Length)). 74 | 75 | -spec get_alphanum_string(string(), non_neg_integer()) -> string(). 76 | get_alphanum_string(S, 0) -> S; 77 | get_alphanum_string(S, N) -> 78 | get_alphanum_string([make_rand_char() | S], N - 1). 79 | 80 | -spec make_rand_char() -> char(). 81 | make_rand_char() -> 82 | map_int_to_char(uniform(0, 61)). 83 | 84 | -spec map_int_to_char(0..61) -> char(). 85 | map_int_to_char(N) when N =< 9 -> N + 48; % Digit. 86 | map_int_to_char(N) when N =< 35 -> N + 55; % Upper-case character. 87 | map_int_to_char(N) when N =< 61 -> N + 61. % Lower-case character. 88 | -------------------------------------------------------------------------------- /src/p1_server.erl: -------------------------------------------------------------------------------- 1 | %% 2 | %% %CopyrightBegin% 3 | %% 4 | %% Copyright Ericsson AB 1996-2014. All Rights Reserved. 5 | %% 6 | %% The contents of this file are subject to the Erlang Public License, 7 | %% Version 1.1, (the "License"); you may not use this file except in 8 | %% compliance with the License. You should have received a copy of the 9 | %% Erlang Public License along with this software. If not, it can be 10 | %% retrieved online at http://www.erlang.org/. 11 | %% 12 | %% Software distributed under the License is distributed on an "AS IS" 13 | %% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 14 | %% the License for the specific language governing rights and limitations 15 | %% under the License. 16 | %% 17 | %% %CopyrightEnd% 18 | %% 19 | %% The code has been modified and improved by ProcessOne. 20 | %% 21 | %% Copyright 2007-2025 ProcessOne 22 | %% 23 | %% The change adds the following features: 24 | %% - You can send exit(priority_shutdown) to the p1_fsm process to 25 | %% terminate immediatetly. If the fsm trap_exit process flag has been 26 | %% set to true, the FSM terminate function will called. 27 | %% - You can pass the gen_fsm options to control resource usage. 28 | %% {max_queue, N} will exit the process with priority_shutdown 29 | %% - You can limit the time processing a message (TODO): If the 30 | %% message processing does not return in a given period of time, the 31 | %% process will be terminated. 32 | %% - You might customize the State data before sending it to error_logger 33 | %% in case of a crash (just export the function print_state/1) 34 | %% 35 | -module(p1_server). 36 | 37 | %%% --------------------------------------------------- 38 | %%% 39 | %%% The idea behind THIS server is that the user module 40 | %%% provides (different) functions to handle different 41 | %%% kind of inputs. 42 | %%% If the Parent process terminates the Module:terminate/2 43 | %%% function is called. 44 | %%% 45 | %%% The user module should export: 46 | %%% 47 | %%% init(Args) 48 | %%% ==> {ok, State} 49 | %%% {ok, State, Timeout} 50 | %%% ignore 51 | %%% {stop, Reason} 52 | %%% 53 | %%% handle_call(Msg, {From, Tag}, State) 54 | %%% 55 | %%% ==> {reply, Reply, State} 56 | %%% {reply, Reply, State, Timeout} 57 | %%% {noreply, State} 58 | %%% {noreply, State, Timeout} 59 | %%% {stop, Reason, Reply, State} 60 | %%% Reason = normal | shutdown | Term terminate(State) is called 61 | %%% 62 | %%% handle_cast(Msg, State) 63 | %%% 64 | %%% ==> {noreply, State} 65 | %%% {noreply, State, Timeout} 66 | %%% {stop, Reason, State} 67 | %%% Reason = normal | shutdown | Term terminate(State) is called 68 | %%% 69 | %%% handle_info(Info, State) Info is e.g. {'EXIT', P, R}, {nodedown, N}, ... 70 | %%% 71 | %%% ==> {noreply, State} 72 | %%% {noreply, State, Timeout} 73 | %%% {stop, Reason, State} 74 | %%% Reason = normal | shutdown | Term, terminate(State) is called 75 | %%% 76 | %%% terminate(Reason, State) Let the user module clean up 77 | %%% always called when server terminates 78 | %%% 79 | %%% ==> ok 80 | %%% 81 | %%% 82 | %%% The work flow (of the server) can be described as follows: 83 | %%% 84 | %%% User module Generic 85 | %%% ----------- ------- 86 | %%% start -----> start 87 | %%% init <----- . 88 | %%% 89 | %%% loop 90 | %%% handle_call <----- . 91 | %%% -----> reply 92 | %%% 93 | %%% handle_cast <----- . 94 | %%% 95 | %%% handle_info <----- . 96 | %%% 97 | %%% terminate <----- . 98 | %%% 99 | %%% -----> reply 100 | %%% 101 | %%% 102 | %%% --------------------------------------------------- 103 | 104 | %% API 105 | -export([start/3, start/4, 106 | start_link/3, start_link/4, 107 | call/2, call/3, 108 | cast/2, reply/2, 109 | abcast/2, abcast/3, 110 | multi_call/2, multi_call/3, multi_call/4, 111 | enter_loop/3, enter_loop/4, enter_loop/5, wake_hib/6]). 112 | 113 | %% System exports 114 | -export([system_continue/3, 115 | system_terminate/4, 116 | system_code_change/4, 117 | system_get_state/1, 118 | system_replace_state/2, 119 | format_status/2]). 120 | 121 | %% Internal exports 122 | -export([init_it/6]). 123 | 124 | -import(error_logger, [format/2]). 125 | 126 | %%% Internal gen_fsm state 127 | %%% This state is used to defined resource control values: 128 | -record(limits, {max_queue :: non_neg_integer() | undefined}). 129 | 130 | %%%========================================================================= 131 | %%% API 132 | %%%========================================================================= 133 | 134 | -callback init(Args :: term()) -> 135 | {ok, State :: term()} | {ok, State :: term(), timeout() | hibernate} | 136 | {stop, Reason :: term()} | ignore. 137 | -callback handle_call(Request :: term(), From :: {pid(), Tag :: term()}, 138 | State :: term()) -> 139 | {reply, Reply :: term(), NewState :: term()} | 140 | {reply, Reply :: term(), NewState :: term(), timeout() | hibernate} | 141 | {noreply, NewState :: term()} | 142 | {noreply, NewState :: term(), timeout() | hibernate} | 143 | {stop, Reason :: term(), Reply :: term(), NewState :: term()} | 144 | {stop, Reason :: term(), NewState :: term()}. 145 | -callback handle_cast(Request :: term(), State :: term()) -> 146 | {noreply, NewState :: term()} | 147 | {noreply, NewState :: term(), timeout() | hibernate} | 148 | {stop, Reason :: term(), NewState :: term()}. 149 | -callback handle_info(Info :: timeout | term(), State :: term()) -> 150 | {noreply, NewState :: term()} | 151 | {noreply, NewState :: term(), timeout() | hibernate} | 152 | {stop, Reason :: term(), NewState :: term()}. 153 | -callback terminate(Reason :: (normal | shutdown | {shutdown, term()} | 154 | term()), 155 | State :: term()) -> 156 | term(). 157 | -callback code_change(OldVsn :: (term() | {down, term()}), State :: term(), 158 | Extra :: term()) -> 159 | {ok, NewState :: term()} | {error, Reason :: term()}. 160 | 161 | %%% ----------------------------------------------------------------- 162 | %%% Starts a generic server. 163 | %%% start(Mod, Args, Options) 164 | %%% start(Name, Mod, Args, Options) 165 | %%% start_link(Mod, Args, Options) 166 | %%% start_link(Name, Mod, Args, Options) where: 167 | %%% Name ::= {local, atom()} | {global, atom()} | {via, atom(), term()} 168 | %%% Mod ::= atom(), callback module implementing the 'real' server 169 | %%% Args ::= term(), init arguments (to Mod:init/1) 170 | %%% Options ::= [{timeout, Timeout} | {debug, [Flag]}] 171 | %%% Flag ::= trace | log | {logfile, File} | statistics | debug 172 | %%% (debug == log && statistics) 173 | %%% Returns: {ok, Pid} | 174 | %%% {error, {already_started, Pid}} | 175 | %%% {error, Reason} 176 | %%% ----------------------------------------------------------------- 177 | start(Mod, Args, Options) -> 178 | gen:start(?MODULE, nolink, Mod, Args, Options). 179 | 180 | start(Name, Mod, Args, Options) -> 181 | gen:start(?MODULE, nolink, Name, Mod, Args, Options). 182 | 183 | start_link(Mod, Args, Options) -> 184 | gen:start(?MODULE, link, Mod, Args, Options). 185 | 186 | start_link(Name, Mod, Args, Options) -> 187 | gen:start(?MODULE, link, Name, Mod, Args, Options). 188 | 189 | 190 | %% ----------------------------------------------------------------- 191 | %% Make a call to a generic server. 192 | %% If the server is located at another node, that node will 193 | %% be monitored. 194 | %% If the client is trapping exits and is linked server termination 195 | %% is handled here (? Shall we do that here (or rely on timeouts) ?). 196 | %% ----------------------------------------------------------------- 197 | call(Name, Request) -> 198 | case catch gen:call(Name, '$gen_call', Request) of 199 | {ok,Res} -> 200 | Res; 201 | {'EXIT',Reason} -> 202 | exit({Reason, {?MODULE, call, [Name, Request]}}) 203 | end. 204 | 205 | call(Name, Request, Timeout) -> 206 | case catch gen:call(Name, '$gen_call', Request, Timeout) of 207 | {ok,Res} -> 208 | Res; 209 | {'EXIT',Reason} -> 210 | exit({Reason, {?MODULE, call, [Name, Request, Timeout]}}) 211 | end. 212 | 213 | %% ----------------------------------------------------------------- 214 | %% Make a cast to a generic server. 215 | %% ----------------------------------------------------------------- 216 | cast({global,Name}, Request) -> 217 | catch global:send(Name, cast_msg(Request)), 218 | ok; 219 | cast({via, Mod, Name}, Request) -> 220 | catch Mod:send(Name, cast_msg(Request)), 221 | ok; 222 | cast({Name,Node}=Dest, Request) when is_atom(Name), is_atom(Node) -> 223 | do_cast(Dest, Request); 224 | cast(Dest, Request) when is_atom(Dest) -> 225 | do_cast(Dest, Request); 226 | cast(Dest, Request) when is_pid(Dest) -> 227 | do_cast(Dest, Request). 228 | 229 | do_cast(Dest, Request) -> 230 | do_send(Dest, cast_msg(Request)), 231 | ok. 232 | 233 | cast_msg(Request) -> {'$gen_cast',Request}. 234 | 235 | %% ----------------------------------------------------------------- 236 | %% Send a reply to the client. 237 | %% ----------------------------------------------------------------- 238 | reply({To, Tag}, Reply) -> 239 | catch To ! {Tag, Reply}. 240 | 241 | %% ----------------------------------------------------------------- 242 | %% Asynchronous broadcast, returns nothing, it's just send 'n' pray 243 | %%----------------------------------------------------------------- 244 | abcast(Name, Request) when is_atom(Name) -> 245 | do_abcast([node() | nodes()], Name, cast_msg(Request)). 246 | 247 | abcast(Nodes, Name, Request) when is_list(Nodes), is_atom(Name) -> 248 | do_abcast(Nodes, Name, cast_msg(Request)). 249 | 250 | do_abcast([Node|Nodes], Name, Msg) when is_atom(Node) -> 251 | do_send({Name,Node},Msg), 252 | do_abcast(Nodes, Name, Msg); 253 | do_abcast([], _,_) -> abcast. 254 | 255 | %%% ----------------------------------------------------------------- 256 | %%% Make a call to servers at several nodes. 257 | %%% Returns: {[Replies],[BadNodes]} 258 | %%% A Timeout can be given 259 | %%% 260 | %%% A middleman process is used in case late answers arrives after 261 | %%% the timeout. If they would be allowed to glog the callers message 262 | %%% queue, it would probably become confused. Late answers will 263 | %%% now arrive to the terminated middleman and so be discarded. 264 | %%% ----------------------------------------------------------------- 265 | multi_call(Name, Req) 266 | when is_atom(Name) -> 267 | do_multi_call([node() | nodes()], Name, Req, infinity). 268 | 269 | multi_call(Nodes, Name, Req) 270 | when is_list(Nodes), is_atom(Name) -> 271 | do_multi_call(Nodes, Name, Req, infinity). 272 | 273 | multi_call(Nodes, Name, Req, infinity) -> 274 | do_multi_call(Nodes, Name, Req, infinity); 275 | multi_call(Nodes, Name, Req, Timeout) 276 | when is_list(Nodes), is_atom(Name), is_integer(Timeout), Timeout >= 0 -> 277 | do_multi_call(Nodes, Name, Req, Timeout). 278 | 279 | 280 | %%----------------------------------------------------------------- 281 | %% enter_loop(Mod, Options, State, , ) ->_ 282 | %% 283 | %% Description: Makes an existing process into a gen_server. 284 | %% The calling process will enter the gen_server receive 285 | %% loop and become a gen_server process. 286 | %% The process *must* have been started using one of the 287 | %% start functions in proc_lib, see proc_lib(3). 288 | %% The user is responsible for any initialization of the 289 | %% process, including registering a name for it. 290 | %%----------------------------------------------------------------- 291 | enter_loop(Mod, Options, State) -> 292 | enter_loop(Mod, Options, State, self(), infinity). 293 | 294 | enter_loop(Mod, Options, State, ServerName = {Scope, _}) 295 | when Scope == local; Scope == global -> 296 | enter_loop(Mod, Options, State, ServerName, infinity); 297 | 298 | enter_loop(Mod, Options, State, ServerName = {via, _, _}) -> 299 | enter_loop(Mod, Options, State, ServerName, infinity); 300 | 301 | enter_loop(Mod, Options, State, Timeout) -> 302 | enter_loop(Mod, Options, State, self(), Timeout). 303 | 304 | enter_loop(Mod, Options, State, ServerName, Timeout) -> 305 | Name = get_proc_name(ServerName), 306 | Parent = get_parent(), 307 | Debug = debug_options(Name, Options), 308 | Limits = limit_options(Options), 309 | Queue = queue:new(), 310 | QueueLen = 0, 311 | loop(Parent, Name, State, Mod, Timeout, Debug, 312 | Limits, Queue, QueueLen). 313 | 314 | %%%======================================================================== 315 | %%% Gen-callback functions 316 | %%%======================================================================== 317 | 318 | %%% --------------------------------------------------- 319 | %%% Initiate the new process. 320 | %%% Register the name using the Rfunc function 321 | %%% Calls the Mod:init/Args function. 322 | %%% Finally an acknowledge is sent to Parent and the main 323 | %%% loop is entered. 324 | %%% --------------------------------------------------- 325 | init_it(Starter, self, Name, Mod, Args, Options) -> 326 | init_it(Starter, self(), Name, Mod, Args, Options); 327 | init_it(Starter, Parent, Name0, Mod, Args, Options) -> 328 | Name = name(Name0), 329 | Debug = debug_options(Name, Options), 330 | Limits = limit_options(Options), 331 | Queue = queue:new(), 332 | QueueLen = 0, 333 | case catch Mod:init(Args) of 334 | {ok, State} -> 335 | proc_lib:init_ack(Starter, {ok, self()}), 336 | loop(Parent, Name, State, Mod, infinity, Debug, 337 | Limits, Queue, QueueLen); 338 | {ok, State, Timeout} -> 339 | proc_lib:init_ack(Starter, {ok, self()}), 340 | loop(Parent, Name, State, Mod, Timeout, Debug, 341 | Limits, Queue, QueueLen); 342 | {stop, Reason} -> 343 | %% For consistency, we must make sure that the 344 | %% registered name (if any) is unregistered before 345 | %% the parent process is notified about the failure. 346 | %% (Otherwise, the parent process could get 347 | %% an 'already_started' error if it immediately 348 | %% tried starting the process again.) 349 | unregister_name(Name0), 350 | proc_lib:init_ack(Starter, {error, Reason}), 351 | exit(Reason); 352 | ignore -> 353 | unregister_name(Name0), 354 | proc_lib:init_ack(Starter, ignore), 355 | exit(normal); 356 | {'EXIT', Reason} -> 357 | unregister_name(Name0), 358 | proc_lib:init_ack(Starter, {error, Reason}), 359 | exit(Reason); 360 | Else -> 361 | Error = {bad_return_value, Else}, 362 | proc_lib:init_ack(Starter, {error, Error}), 363 | exit(Error) 364 | end. 365 | 366 | name({local,Name}) -> Name; 367 | name({global,Name}) -> Name; 368 | name({via,_, Name}) -> Name; 369 | name(Pid) when is_pid(Pid) -> Pid. 370 | 371 | unregister_name({local,Name}) -> 372 | _ = (catch unregister(Name)); 373 | unregister_name({global,Name}) -> 374 | _ = global:unregister_name(Name); 375 | unregister_name({via, Mod, Name}) -> 376 | _ = Mod:unregister_name(Name); 377 | unregister_name(Pid) when is_pid(Pid) -> 378 | Pid. 379 | 380 | %%%======================================================================== 381 | %%% Internal functions 382 | %%%======================================================================== 383 | %%% --------------------------------------------------- 384 | %%% The MAIN loop. 385 | %%% --------------------------------------------------- 386 | loop(Parent, Name, State, Mod, hibernate, Debug, 387 | Limits, Queue, QueueLen) 388 | when QueueLen > 0 -> 389 | case queue:out(Queue) of 390 | {{value, Msg}, Queue1} -> 391 | decode_msg(Msg, Parent, Name, State, Mod, hibernate, 392 | Debug, Limits, Queue1, QueueLen - 1, false); 393 | {empty, _} -> 394 | Reason = internal_queue_error, 395 | error_info(Mod, Reason, Name, hibernate, State, Debug), 396 | exit(Reason) 397 | end; 398 | loop(Parent, Name, State, Mod, hibernate, Debug, 399 | Limits, _Queue, _QueueLen) -> 400 | proc_lib:hibernate(?MODULE,wake_hib,[Parent, Name, State, Mod, Debug, 401 | Limits]); 402 | %% First we test if we have reach a defined limit ... 403 | loop(Parent, Name, State, Mod, Time, Debug, 404 | Limits, Queue, QueueLen) -> 405 | try 406 | message_queue_len(Limits, QueueLen) 407 | %% TODO: We can add more limit checking here... 408 | catch 409 | {process_limit, Limit} -> 410 | Reason = {process_limit, Limit}, 411 | Msg = {'EXIT', Parent, {error, {process_limit, Limit}}}, 412 | terminate(Reason, Name, Msg, Mod, State, Debug, 413 | queue:new()) 414 | end, 415 | process_message(Parent, Name, State, Mod, Time, Debug, 416 | Limits, Queue, QueueLen). 417 | 418 | %% ... then we can process a new message: 419 | process_message(Parent, Name, State, Mod, Time, Debug, 420 | Limits, Queue, QueueLen) -> 421 | {Msg, Queue1, QueueLen1} = collect_messages(Queue, QueueLen, Time), 422 | decode_msg(Msg, Parent, Name, State, Mod, Time, Debug, 423 | Limits, Queue1, QueueLen1, false). 424 | 425 | collect_messages(Queue, QueueLen, Time) -> 426 | receive 427 | Input -> 428 | case Input of 429 | {'EXIT', _Parent, priority_shutdown} -> 430 | {Input, Queue, QueueLen}; 431 | _ -> 432 | collect_messages( 433 | queue:in(Input, Queue), QueueLen + 1, Time) 434 | end 435 | after 0 -> 436 | case queue:out(Queue) of 437 | {{value, Msg}, Queue1} -> 438 | {Msg, Queue1, QueueLen - 1}; 439 | {empty, _} -> 440 | receive 441 | Input -> 442 | {Input, Queue, QueueLen} 443 | after Time -> 444 | {timeout, Queue, QueueLen} 445 | end 446 | end 447 | end. 448 | 449 | wake_hib(Parent, Name, State, Mod, Debug, 450 | Limits) -> 451 | Msg = receive 452 | Input -> 453 | Input 454 | end, 455 | Queue = queue:new(), 456 | QueueLen = 0, 457 | decode_msg(Msg, Parent, Name, State, Mod, hibernate, Debug, 458 | Limits, Queue, QueueLen, true). 459 | 460 | decode_msg(Msg, Parent, Name, State, Mod, Time, Debug, 461 | Limits, Queue, QueueLen, Hib) -> 462 | put('$internal_queue_len', QueueLen), 463 | case Msg of 464 | {system, From, Req} -> 465 | sys:handle_system_msg(Req, From, Parent, ?MODULE, Debug, 466 | [Name, State, Mod, Time, 467 | Limits, Queue, QueueLen], Hib); 468 | {'EXIT', Parent, Reason} -> 469 | terminate(Reason, Name, Msg, Mod, State, Debug, Queue); 470 | _Msg when Debug =:= [] -> 471 | handle_msg(Msg, Parent, Name, State, Mod, 472 | Limits, Queue, QueueLen); 473 | _Msg -> 474 | Debug1 = sys:handle_debug(Debug, fun print_event/3, 475 | Name, {in, Msg}), 476 | handle_msg(Msg, Parent, Name, State, Mod, Debug1, 477 | Limits, Queue, QueueLen) 478 | end. 479 | 480 | %%% --------------------------------------------------- 481 | %%% Send/receive functions 482 | %%% --------------------------------------------------- 483 | do_send(Dest, Msg) -> 484 | case catch erlang:send(Dest, Msg, [noconnect]) of 485 | noconnect -> 486 | spawn(erlang, send, [Dest,Msg]); 487 | Other -> 488 | Other 489 | end. 490 | 491 | do_multi_call(Nodes, Name, Req, infinity) -> 492 | Tag = make_ref(), 493 | Monitors = send_nodes(Nodes, Name, Tag, Req), 494 | rec_nodes(Tag, Monitors, Name, undefined); 495 | do_multi_call(Nodes, Name, Req, Timeout) -> 496 | Tag = make_ref(), 497 | Caller = self(), 498 | Receiver = 499 | spawn( 500 | fun() -> 501 | %% Middleman process. Should be unsensitive to regular 502 | %% exit signals. The synchronization is needed in case 503 | %% the receiver would exit before the caller started 504 | %% the monitor. 505 | process_flag(trap_exit, true), 506 | Mref = erlang:monitor(process, Caller), 507 | receive 508 | {Caller,Tag} -> 509 | Monitors = send_nodes(Nodes, Name, Tag, Req), 510 | TimerId = erlang:start_timer(Timeout, self(), ok), 511 | Result = rec_nodes(Tag, Monitors, Name, TimerId), 512 | exit({self(),Tag,Result}); 513 | {'DOWN',Mref,_,_,_} -> 514 | %% Caller died before sending us the go-ahead. 515 | %% Give up silently. 516 | exit(normal) 517 | end 518 | end), 519 | Mref = erlang:monitor(process, Receiver), 520 | Receiver ! {self(),Tag}, 521 | receive 522 | {'DOWN',Mref,_,_,{Receiver,Tag,Result}} -> 523 | Result; 524 | {'DOWN',Mref,_,_,Reason} -> 525 | %% The middleman code failed. Or someone did 526 | %% exit(_, kill) on the middleman process => Reason==killed 527 | exit(Reason) 528 | end. 529 | 530 | send_nodes(Nodes, Name, Tag, Req) -> 531 | send_nodes(Nodes, Name, Tag, Req, []). 532 | 533 | send_nodes([Node|Tail], Name, Tag, Req, Monitors) 534 | when is_atom(Node) -> 535 | Monitor = start_monitor(Node, Name), 536 | %% Handle non-existing names in rec_nodes. 537 | catch {Name, Node} ! {'$gen_call', {self(), {Tag, Node}}, Req}, 538 | send_nodes(Tail, Name, Tag, Req, [Monitor | Monitors]); 539 | send_nodes([_Node|Tail], Name, Tag, Req, Monitors) -> 540 | %% Skip non-atom Node 541 | send_nodes(Tail, Name, Tag, Req, Monitors); 542 | send_nodes([], _Name, _Tag, _Req, Monitors) -> 543 | Monitors. 544 | 545 | %% Against old nodes: 546 | %% If no reply has been delivered within 2 secs. (per node) check that 547 | %% the server really exists and wait for ever for the answer. 548 | %% 549 | %% Against contemporary nodes: 550 | %% Wait for reply, server 'DOWN', or timeout from TimerId. 551 | 552 | rec_nodes(Tag, Nodes, Name, TimerId) -> 553 | rec_nodes(Tag, Nodes, Name, [], [], 2000, TimerId). 554 | 555 | rec_nodes(Tag, [{N,R}|Tail], Name, Badnodes, Replies, Time, TimerId ) -> 556 | receive 557 | {'DOWN', R, _, _, _} -> 558 | rec_nodes(Tag, Tail, Name, [N|Badnodes], Replies, Time, TimerId); 559 | {{Tag, N}, Reply} -> %% Tag is bound !!! 560 | erlang:demonitor(R, [flush]), 561 | rec_nodes(Tag, Tail, Name, Badnodes, 562 | [{N,Reply}|Replies], Time, TimerId); 563 | {timeout, TimerId, _} -> 564 | erlang:demonitor(R, [flush]), 565 | %% Collect all replies that already have arrived 566 | rec_nodes_rest(Tag, Tail, Name, [N|Badnodes], Replies) 567 | end; 568 | rec_nodes(Tag, [N|Tail], Name, Badnodes, Replies, Time, TimerId) -> 569 | %% R6 node 570 | receive 571 | {nodedown, N} -> 572 | monitor_node(N, false), 573 | rec_nodes(Tag, Tail, Name, [N|Badnodes], Replies, 2000, TimerId); 574 | {{Tag, N}, Reply} -> %% Tag is bound !!! 575 | receive {nodedown, N} -> ok after 0 -> ok end, 576 | monitor_node(N, false), 577 | rec_nodes(Tag, Tail, Name, Badnodes, 578 | [{N,Reply}|Replies], 2000, TimerId); 579 | {timeout, TimerId, _} -> 580 | receive {nodedown, N} -> ok after 0 -> ok end, 581 | monitor_node(N, false), 582 | %% Collect all replies that already have arrived 583 | rec_nodes_rest(Tag, Tail, Name, [N | Badnodes], Replies) 584 | after Time -> 585 | case rpc:call(N, erlang, whereis, [Name]) of 586 | Pid when is_pid(Pid) -> % It exists try again. 587 | rec_nodes(Tag, [N|Tail], Name, Badnodes, 588 | Replies, infinity, TimerId); 589 | _ -> % badnode 590 | receive {nodedown, N} -> ok after 0 -> ok end, 591 | monitor_node(N, false), 592 | rec_nodes(Tag, Tail, Name, [N|Badnodes], 593 | Replies, 2000, TimerId) 594 | end 595 | end; 596 | rec_nodes(_, [], _, Badnodes, Replies, _, TimerId) -> 597 | case catch erlang:cancel_timer(TimerId) of 598 | false -> % It has already sent it's message 599 | receive 600 | {timeout, TimerId, _} -> ok 601 | after 0 -> 602 | ok 603 | end; 604 | _ -> % Timer was cancelled, or TimerId was 'undefined' 605 | ok 606 | end, 607 | {Replies, Badnodes}. 608 | 609 | %% Collect all replies that already have arrived 610 | rec_nodes_rest(Tag, [{N,R}|Tail], Name, Badnodes, Replies) -> 611 | receive 612 | {'DOWN', R, _, _, _} -> 613 | rec_nodes_rest(Tag, Tail, Name, [N|Badnodes], Replies); 614 | {{Tag, N}, Reply} -> %% Tag is bound !!! 615 | erlang:demonitor(R, [flush]), 616 | rec_nodes_rest(Tag, Tail, Name, Badnodes, [{N,Reply}|Replies]) 617 | after 0 -> 618 | erlang:demonitor(R, [flush]), 619 | rec_nodes_rest(Tag, Tail, Name, [N|Badnodes], Replies) 620 | end; 621 | rec_nodes_rest(Tag, [N|Tail], Name, Badnodes, Replies) -> 622 | %% R6 node 623 | receive 624 | {nodedown, N} -> 625 | monitor_node(N, false), 626 | rec_nodes_rest(Tag, Tail, Name, [N|Badnodes], Replies); 627 | {{Tag, N}, Reply} -> %% Tag is bound !!! 628 | receive {nodedown, N} -> ok after 0 -> ok end, 629 | monitor_node(N, false), 630 | rec_nodes_rest(Tag, Tail, Name, Badnodes, [{N,Reply}|Replies]) 631 | after 0 -> 632 | receive {nodedown, N} -> ok after 0 -> ok end, 633 | monitor_node(N, false), 634 | rec_nodes_rest(Tag, Tail, Name, [N|Badnodes], Replies) 635 | end; 636 | rec_nodes_rest(_Tag, [], _Name, Badnodes, Replies) -> 637 | {Replies, Badnodes}. 638 | 639 | 640 | %%% --------------------------------------------------- 641 | %%% Monitor functions 642 | %%% --------------------------------------------------- 643 | 644 | start_monitor(Node, Name) when is_atom(Node), is_atom(Name) -> 645 | if node() =:= nonode@nohost, Node =/= nonode@nohost -> 646 | Ref = make_ref(), 647 | self() ! {'DOWN', Ref, process, {Name, Node}, noconnection}, 648 | {Node, Ref}; 649 | true -> 650 | case catch erlang:monitor(process, {Name, Node}) of 651 | {'EXIT', _} -> 652 | %% Remote node is R6 653 | monitor_node(Node, true), 654 | Node; 655 | Ref when is_reference(Ref) -> 656 | {Node, Ref} 657 | end 658 | end. 659 | 660 | %%% --------------------------------------------------- 661 | %%% Message handling functions 662 | %%% --------------------------------------------------- 663 | 664 | dispatch({'$gen_cast', Msg}, Mod, State) -> 665 | Mod:handle_cast(Msg, State); 666 | dispatch(Info, Mod, State) -> 667 | Mod:handle_info(Info, State). 668 | 669 | handle_msg({'$gen_call', From, Msg}, Parent, Name, State, Mod, 670 | Limits, Queue, QueueLen) -> 671 | case catch Mod:handle_call(Msg, From, State) of 672 | {reply, Reply, NState} -> 673 | reply(From, Reply), 674 | loop(Parent, Name, NState, Mod, infinity, [], 675 | Limits, Queue, QueueLen); 676 | {reply, Reply, NState, Time1} -> 677 | reply(From, Reply), 678 | loop(Parent, Name, NState, Mod, Time1, [], 679 | Limits, Queue, QueueLen); 680 | {noreply, NState} -> 681 | loop(Parent, Name, NState, Mod, infinity, [], 682 | Limits, Queue, QueueLen); 683 | {noreply, NState, Time1} -> 684 | loop(Parent, Name, NState, Mod, Time1, [], 685 | Limits, Queue, QueueLen); 686 | {stop, Reason, Reply, NState} -> 687 | {'EXIT', R} = 688 | (catch terminate(Reason, Name, Msg, Mod, NState, [], Queue)), 689 | reply(From, Reply), 690 | exit(R); 691 | Other -> handle_common_reply(Other, Parent, Name, Msg, Mod, State, 692 | Limits, Queue, QueueLen) 693 | end; 694 | handle_msg(Msg, Parent, Name, State, Mod, 695 | Limits, Queue, QueueLen) -> 696 | Reply = (catch dispatch(Msg, Mod, State)), 697 | handle_common_reply(Reply, Parent, Name, Msg, Mod, State, 698 | Limits, Queue, QueueLen). 699 | 700 | handle_msg({'$gen_call', From, Msg}, Parent, Name, State, Mod, Debug, 701 | Limits, Queue, QueueLen) -> 702 | case catch Mod:handle_call(Msg, From, State) of 703 | {reply, Reply, NState} -> 704 | Debug1 = reply(Name, From, Reply, NState, Debug), 705 | loop(Parent, Name, NState, Mod, infinity, Debug1, 706 | Limits, Queue, QueueLen); 707 | {reply, Reply, NState, Time1} -> 708 | Debug1 = reply(Name, From, Reply, NState, Debug), 709 | loop(Parent, Name, NState, Mod, Time1, Debug1, 710 | Limits, Queue, QueueLen); 711 | {noreply, NState} -> 712 | Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, 713 | {noreply, NState}), 714 | loop(Parent, Name, NState, Mod, infinity, Debug1, 715 | Limits, Queue, QueueLen); 716 | {noreply, NState, Time1} -> 717 | Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, 718 | {noreply, NState}), 719 | loop(Parent, Name, NState, Mod, Time1, Debug1, 720 | Limits, Queue, QueueLen); 721 | {stop, Reason, Reply, NState} -> 722 | {'EXIT', R} = 723 | (catch terminate(Reason, Name, Msg, Mod, NState, Debug, Queue)), 724 | reply(Name, From, Reply, NState, Debug), 725 | exit(R); 726 | Other -> 727 | handle_common_reply(Other, Parent, Name, Msg, Mod, State, Debug, 728 | Limits, Queue, QueueLen) 729 | end; 730 | handle_msg(Msg, Parent, Name, State, Mod, Debug, 731 | Limits, Queue, QueueLen) -> 732 | Reply = (catch dispatch(Msg, Mod, State)), 733 | handle_common_reply(Reply, Parent, Name, Msg, Mod, State, Debug, 734 | Limits, Queue, QueueLen). 735 | 736 | handle_common_reply(Reply, Parent, Name, Msg, Mod, State, 737 | Limits, Queue, QueueLen) -> 738 | case Reply of 739 | {noreply, NState} -> 740 | loop(Parent, Name, NState, Mod, infinity, [], 741 | Limits, Queue, QueueLen); 742 | {noreply, NState, Time1} -> 743 | loop(Parent, Name, NState, Mod, Time1, [], 744 | Limits, Queue, QueueLen); 745 | {stop, Reason, NState} -> 746 | terminate(Reason, Name, Msg, Mod, NState, [], Queue); 747 | {'EXIT', What} -> 748 | terminate(What, Name, Msg, Mod, State, [], Queue); 749 | _ -> 750 | terminate({bad_return_value, Reply}, Name, Msg, Mod, State, [], 751 | Queue) 752 | end. 753 | 754 | handle_common_reply(Reply, Parent, Name, Msg, Mod, State, Debug, 755 | Limits, Queue, QueueLen) -> 756 | case Reply of 757 | {noreply, NState} -> 758 | Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, 759 | {noreply, NState}), 760 | loop(Parent, Name, NState, Mod, infinity, Debug1, 761 | Limits, Queue, QueueLen); 762 | {noreply, NState, Time1} -> 763 | Debug1 = sys:handle_debug(Debug, fun print_event/3, Name, 764 | {noreply, NState}), 765 | loop(Parent, Name, NState, Mod, Time1, Debug1, 766 | Limits, Queue, QueueLen); 767 | {stop, Reason, NState} -> 768 | terminate(Reason, Name, Msg, Mod, NState, Debug, Queue); 769 | {'EXIT', What} -> 770 | terminate(What, Name, Msg, Mod, State, Debug, Queue); 771 | _ -> 772 | terminate({bad_return_value, Reply}, Name, Msg, Mod, State, Debug, 773 | Queue) 774 | end. 775 | 776 | reply(Name, {To, Tag}, Reply, State, Debug) -> 777 | reply({To, Tag}, Reply), 778 | sys:handle_debug(Debug, fun print_event/3, Name, 779 | {out, Reply, To, State} ). 780 | 781 | 782 | %%----------------------------------------------------------------- 783 | %% Callback functions for system messages handling. 784 | %%----------------------------------------------------------------- 785 | system_continue(Parent, Debug, [Name, State, Mod, Time, 786 | Limits, Queue, QueueLen]) -> 787 | loop(Parent, Name, State, Mod, Time, Debug, 788 | Limits, Queue, QueueLen). 789 | 790 | -spec system_terminate(_, _, _, [_]) -> no_return(). 791 | 792 | system_terminate(Reason, _Parent, Debug, [Name, State, Mod, _Time, 793 | _Limits, Queue, _QueueLen]) -> 794 | terminate(Reason, Name, [], Mod, State, Debug, Queue). 795 | 796 | system_code_change([Name, State, Mod, Time, 797 | Limits, Queue, QueueLen], _Module, OldVsn, Extra) -> 798 | case catch Mod:code_change(OldVsn, State, Extra) of 799 | {ok, NewState} -> {ok, [Name, NewState, Mod, Time, 800 | Limits, Queue, QueueLen]}; 801 | Else -> Else 802 | end. 803 | 804 | system_get_state([_Name, State, _Mod, _Time, 805 | _Limits, _Queue, _QueueLen]) -> 806 | {ok, State}. 807 | 808 | system_replace_state(StateFun, 809 | [Name, State, Mod, Time, 810 | Limits, Queue, QueueLen]) -> 811 | NState = StateFun(State), 812 | {ok, NState, [Name, NState, Mod, Time, 813 | Limits, Queue, QueueLen]}. 814 | 815 | %%----------------------------------------------------------------- 816 | %% Format debug messages. Print them as the call-back module sees 817 | %% them, not as the real erlang messages. Use trace for that. 818 | %%----------------------------------------------------------------- 819 | print_event(Dev, {in, Msg}, Name) -> 820 | case Msg of 821 | {'$gen_call', {From, _Tag}, Call} -> 822 | io:format(Dev, "*DBG* ~p got call ~p from ~w~n", 823 | [Name, Call, From]); 824 | {'$gen_cast', Cast} -> 825 | io:format(Dev, "*DBG* ~p got cast ~p~n", 826 | [Name, Cast]); 827 | _ -> 828 | io:format(Dev, "*DBG* ~p got ~p~n", [Name, Msg]) 829 | end; 830 | print_event(Dev, {out, Msg, To, State}, Name) -> 831 | io:format(Dev, "*DBG* ~p sent ~p to ~w, new state ~w~n", 832 | [Name, Msg, To, State]); 833 | print_event(Dev, {noreply, State}, Name) -> 834 | io:format(Dev, "*DBG* ~p new state ~w~n", [Name, State]); 835 | print_event(Dev, Event, Name) -> 836 | io:format(Dev, "*DBG* ~p dbg ~p~n", [Name, Event]). 837 | 838 | 839 | %%% --------------------------------------------------- 840 | %%% Terminate the server. 841 | %%% --------------------------------------------------- 842 | 843 | terminate(Reason, Name, Msg, Mod, State, Debug, Queue) -> 844 | lists:foreach( 845 | fun(Message) -> self() ! Message end, 846 | queue:to_list(Queue)), 847 | case catch Mod:terminate(Reason, State) of 848 | {'EXIT', R} -> 849 | error_info(Mod, R, Name, Msg, State, Debug), 850 | exit(R); 851 | _ -> 852 | case Reason of 853 | normal -> 854 | exit(normal); 855 | shutdown -> 856 | exit(shutdown); 857 | {shutdown,_}=Shutdown -> 858 | exit(Shutdown); 859 | priority_shutdown -> 860 | %% Priority shutdown should be considered as 861 | %% shutdown by SASL 862 | exit(shutdown); 863 | {process_limit, _Limit} -> 864 | exit(Reason); 865 | _ -> 866 | FmtState = 867 | case erlang:function_exported(Mod, format_status, 2) of 868 | true -> 869 | Args = [get(), State], 870 | case catch Mod:format_status(terminate, Args) of 871 | {'EXIT', _} -> State; 872 | Else -> Else 873 | end; 874 | _ -> 875 | State 876 | end, 877 | error_info(Mod, Reason, Name, Msg, FmtState, Debug), 878 | exit(Reason) 879 | end 880 | end. 881 | 882 | error_info(_Mod, _Reason, application_controller, _Msg, _State, _Debug) -> 883 | %% OTP-5811 Don't send an error report if it's the system process 884 | %% application_controller which is terminating - let init take care 885 | %% of it instead 886 | ok; 887 | error_info(Mod, Reason, Name, Msg, State, Debug) -> 888 | Reason1 = 889 | case Reason of 890 | {undef,[{M,F,A,L}|MFAs]} -> 891 | case code:is_loaded(M) of 892 | false -> 893 | {'module could not be loaded',[{M,F,A,L}|MFAs]}; 894 | _ -> 895 | case erlang:function_exported(M, F, length(A)) of 896 | true -> 897 | Reason; 898 | false -> 899 | {'function not exported',[{M,F,A,L}|MFAs]} 900 | end 901 | end; 902 | _ -> 903 | Reason 904 | end, 905 | StateToPrint = case erlang:function_exported(Mod, print_state, 1) of 906 | true -> (catch Mod:print_state(State)); 907 | false -> State 908 | end, 909 | format("** Generic server ~p terminating \n" 910 | "** Last message in was ~p~n" 911 | "** When Server state == ~p~n" 912 | "** Reason for termination == ~n** ~p~n", 913 | [Name, Msg, StateToPrint, Reason1]), 914 | sys:print_log(Debug), 915 | ok. 916 | 917 | %%% --------------------------------------------------- 918 | %%% Misc. functions. 919 | %%% --------------------------------------------------- 920 | 921 | opt(Op, [{Op, Value}|_]) -> 922 | {ok, Value}; 923 | opt(Op, [_|Options]) -> 924 | opt(Op, Options); 925 | opt(_, []) -> 926 | false. 927 | 928 | debug_options(Name, Opts) -> 929 | case opt(debug, Opts) of 930 | {ok, Options} -> dbg_opts(Name, Options); 931 | _ -> dbg_opts(Name, []) 932 | end. 933 | 934 | dbg_opts(Name, Opts) -> 935 | case catch sys:debug_options(Opts) of 936 | {'EXIT',_} -> 937 | format("~p: ignoring erroneous debug options - ~p~n", 938 | [Name, Opts]), 939 | []; 940 | Dbg -> 941 | Dbg 942 | end. 943 | 944 | get_proc_name(Pid) when is_pid(Pid) -> 945 | Pid; 946 | get_proc_name({local, Name}) -> 947 | case process_info(self(), registered_name) of 948 | {registered_name, Name} -> 949 | Name; 950 | {registered_name, _Name} -> 951 | exit(process_not_registered); 952 | [] -> 953 | exit(process_not_registered) 954 | end; 955 | get_proc_name({global, Name}) -> 956 | case global:whereis_name(Name) of 957 | undefined -> 958 | exit(process_not_registered_globally); 959 | Pid when Pid =:= self() -> 960 | Name; 961 | _Pid -> 962 | exit(process_not_registered_globally) 963 | end; 964 | get_proc_name({via, Mod, Name}) -> 965 | case Mod:whereis_name(Name) of 966 | undefined -> 967 | exit({process_not_registered_via, Mod}); 968 | Pid when Pid =:= self() -> 969 | Name; 970 | _Pid -> 971 | exit({process_not_registered_via, Mod}) 972 | end. 973 | 974 | get_parent() -> 975 | case get('$ancestors') of 976 | [Parent | _] when is_pid(Parent)-> 977 | Parent; 978 | [Parent | _] when is_atom(Parent)-> 979 | name_to_pid(Parent); 980 | _ -> 981 | exit(process_was_not_started_by_proc_lib) 982 | end. 983 | 984 | name_to_pid(Name) -> 985 | case whereis(Name) of 986 | undefined -> 987 | case global:whereis_name(Name) of 988 | undefined -> 989 | exit(could_not_find_registered_name); 990 | Pid -> 991 | Pid 992 | end; 993 | Pid -> 994 | Pid 995 | end. 996 | 997 | %%----------------------------------------------------------------- 998 | %% Status information 999 | %%----------------------------------------------------------------- 1000 | format_status(Opt, StatusData) -> 1001 | [PDict, SysState, Parent, Debug, [Name, State, Mod, _Time, 1002 | _Limits, _Queue, _QueueLen]] = StatusData, 1003 | Header = gen:format_status_header("Status for generic server", 1004 | Name), 1005 | Log = sys_get_debug(log, Debug, []), 1006 | DefaultStatus = [{data, [{"State", State}]}], 1007 | Specific = 1008 | case erlang:function_exported(Mod, format_status, 2) of 1009 | true -> 1010 | case catch Mod:format_status(Opt, [PDict, State]) of 1011 | {'EXIT', _} -> DefaultStatus; 1012 | StatusList when is_list(StatusList) -> StatusList; 1013 | Else -> [Else] 1014 | end; 1015 | _ -> 1016 | DefaultStatus 1017 | end, 1018 | [{header, Header}, 1019 | {data, [{"Status", SysState}, 1020 | {"Parent", Parent}, 1021 | {"Logged events", Log}]} | 1022 | Specific]. 1023 | 1024 | -ifdef(USE_OLD_SYS_GET_DEBUG). 1025 | sys_get_debug(Item, Debug, Default) -> sys:get_debug(Item, Debug, Default). 1026 | -else. 1027 | sys_get_debug(log, Debug, _Default) -> sys:get_log(Debug). 1028 | -endif. 1029 | 1030 | %%----------------------------------------------------------------- 1031 | %% Resources limit management 1032 | %%----------------------------------------------------------------- 1033 | %% Extract know limit options 1034 | limit_options(Options) -> 1035 | limit_options(Options, #limits{}). 1036 | limit_options([], Limits) -> 1037 | Limits; 1038 | %% Maximum number of messages allowed in the process message queue 1039 | limit_options([{max_queue,N}|Options], Limits) 1040 | when is_integer(N) -> 1041 | NewLimits = Limits#limits{max_queue=N}, 1042 | limit_options(Options, NewLimits); 1043 | limit_options([_|Options], Limits) -> 1044 | limit_options(Options, Limits). 1045 | 1046 | %% Throw max_queue if we have reach the max queue size 1047 | %% Returns ok otherwise 1048 | message_queue_len(#limits{max_queue = undefined}, _QueueLen) -> 1049 | ok; 1050 | message_queue_len(#limits{max_queue = MaxQueue}, QueueLen) -> 1051 | Pid = self(), 1052 | case process_info(Pid, message_queue_len) of 1053 | {message_queue_len, N} when N + QueueLen > MaxQueue -> 1054 | throw({process_limit, {max_queue, N + QueueLen}}); 1055 | _ -> 1056 | ok 1057 | end. 1058 | -------------------------------------------------------------------------------- /src/p1_shaper.erl: -------------------------------------------------------------------------------- 1 | %%%------------------------------------------------------------------- 2 | %%% @author Evgeny Khramtsov 3 | %%% 4 | %%% 5 | %%% Copyright (C) 2002-2025 ProcessOne, SARL. All Rights Reserved. 6 | %%% 7 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 8 | %%% you may not use this file except in compliance with the License. 9 | %%% You may obtain a copy of the License at 10 | %%% 11 | %%% http://www.apache.org/licenses/LICENSE-2.0 12 | %%% 13 | %%% Unless required by applicable law or agreed to in writing, software 14 | %%% distributed under the License is distributed on an "AS IS" BASIS, 15 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 16 | %%% See the License for the specific language governing permissions and 17 | %%% limitations under the License. 18 | %%% 19 | %%%------------------------------------------------------------------- 20 | -module(p1_shaper). 21 | 22 | %% API 23 | -export([new/1, new/2, update/2, pp/1]). 24 | 25 | -record(state, {maxrate = 0 :: integer(), 26 | burst_size = 0 :: integer(), 27 | acquired_credit = 0 :: integer(), 28 | lasttime = 0 :: integer()}). 29 | 30 | -opaque state() :: #state{}. 31 | -export_type([state/0]). 32 | 33 | %%%=================================================================== 34 | %%% API 35 | %%%=================================================================== 36 | -spec new(integer()) -> state(). 37 | new(MaxRate) -> 38 | new(MaxRate, MaxRate). 39 | 40 | -spec new(integer(), integer()) -> state(). 41 | new(MaxRate, BurstSize) -> 42 | #state{maxrate = MaxRate, 43 | burst_size = BurstSize, 44 | acquired_credit = BurstSize, 45 | lasttime = p1_time_compat:system_time(micro_seconds)}. 46 | 47 | -spec update(state(), non_neg_integer()) -> {state(), non_neg_integer()}. 48 | update(#state{maxrate = MR, burst_size = BS, 49 | acquired_credit = AC, lasttime = L} = State, Size) -> 50 | Now = p1_time_compat:system_time(micro_seconds), 51 | AC2 = min(BS, AC + (MR*(Now - L) div 1000000) - Size), 52 | Pause = if AC2 >= 0 -> 0; 53 | true -> -1000*AC2 div MR 54 | end, 55 | {State#state{acquired_credit = AC2, lasttime = Now}, Pause}. 56 | 57 | -spec pp(any()) -> iolist(). 58 | pp(Term) -> 59 | io_lib_pretty:print(Term, fun pp/2). 60 | 61 | %%%=================================================================== 62 | %%% Internal functions 63 | %%%=================================================================== 64 | -spec pp(atom(), non_neg_integer()) -> [atom()] | no. 65 | pp(state, 4) -> record_info(fields, state); 66 | pp(_, _) -> no. 67 | -------------------------------------------------------------------------------- /src/p1_time_compat.erl: -------------------------------------------------------------------------------- 1 | %% 2 | %% %CopyrightBegin% 3 | %% 4 | %% Copyright Ericsson AB 2014-2015. All Rights Reserved. 5 | %% 6 | %% Licensed under the Apache License, Version 2.0 (the "License"); 7 | %% you may not use this file except in compliance with the License. 8 | %% You may obtain a copy of the License at 9 | %% 10 | %% http://www.apache.org/licenses/LICENSE-2.0 11 | %% 12 | %% Unless required by applicable law or agreed to in writing, software 13 | %% distributed under the License is distributed on an "AS IS" BASIS, 14 | %% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15 | %% See the License for the specific language governing permissions and 16 | %% limitations under the License. 17 | %% 18 | %% %CopyrightEnd% 19 | %% 20 | 21 | %% 22 | %% If your code need to be able to execute on ERTS versions both 23 | %% earlier and later than 7.0, the best approach is to use the new 24 | %% time API introduced in ERTS 7.0 and implement a fallback 25 | %% solution using the old primitives to be used on old ERTS 26 | %% versions. This way your code can automatically take advantage 27 | %% of the improvements in the API when available. This is an 28 | %% example of how to implement such an API, but it can be used 29 | %% as is if you want to. Just add (a preferably renamed version of) 30 | %% this module to your project, and call the API via this module 31 | %% instead of calling the BIFs directly. 32 | %% 33 | 34 | -module(p1_time_compat). 35 | 36 | %% We don't want warnings about the use of erlang:now/0 in 37 | %% this module. 38 | -compile(nowarn_deprecated_function). 39 | %% 40 | %% We don't use 41 | %% -compile({nowarn_deprecated_function, [{erlang, now, 0}]}). 42 | %% since this will produce warnings when compiled on systems 43 | %% where it has not yet been deprecated. 44 | %% 45 | 46 | -export([monotonic_time/0, 47 | monotonic_time/1, 48 | system_time/0, 49 | system_time/1, 50 | os_system_time/0, 51 | os_system_time/1, 52 | time_offset/0, 53 | time_offset/1, 54 | convert_time_unit/3, 55 | timestamp/0, 56 | unique_timestamp/0, 57 | unique_integer/0, 58 | unique_integer/1, 59 | monitor/2, 60 | system_info/1, 61 | system_flag/2]). 62 | 63 | -ifdef(NEED_TIME_FALLBACKS). 64 | monotonic_time() -> 65 | erlang_system_time_fallback(). 66 | 67 | monotonic_time(Unit) -> 68 | STime = erlang_system_time_fallback(), 69 | convert_time_unit_fallback(STime, native, Unit). 70 | 71 | system_time() -> 72 | erlang_system_time_fallback(). 73 | 74 | system_time(Unit) -> 75 | STime = erlang_system_time_fallback(), 76 | convert_time_unit_fallback(STime, native, Unit). 77 | 78 | os_system_time() -> 79 | os_system_time_fallback(). 80 | 81 | os_system_time(Unit) -> 82 | STime = os_system_time_fallback(), 83 | try 84 | convert_time_unit_fallback(STime, native, Unit) 85 | catch 86 | error:bad_time_unit -> erlang:error(badarg, [Unit]) 87 | end. 88 | 89 | time_offset() -> 90 | %% Erlang system time and Erlang monotonic 91 | %% time are always aligned 92 | 0. 93 | 94 | time_offset(Unit) -> 95 | _ = integer_time_unit(Unit), 96 | %% Erlang system time and Erlang monotonic 97 | %% time are always aligned 98 | 0. 99 | 100 | convert_time_unit(Time, FromUnit, ToUnit) -> 101 | try 102 | convert_time_unit_fallback(Time, FromUnit, ToUnit) 103 | catch 104 | _:_ -> 105 | erlang:error(badarg, [Time, FromUnit, ToUnit]) 106 | end. 107 | 108 | timestamp() -> 109 | erlang:now(). 110 | 111 | unique_timestamp() -> 112 | erlang:now(). 113 | 114 | unique_integer() -> 115 | {MS, S, US} = erlang:now(), 116 | (MS*1000000+S)*1000000+US. 117 | 118 | unique_integer(Modifiers) -> 119 | case is_valid_modifier_list(Modifiers) of 120 | true -> 121 | %% now() converted to an integer 122 | %% fulfill the requirements of 123 | %% all modifiers: unique, positive, 124 | %% and monotonic... 125 | {MS, S, US} = erlang:now(), 126 | (MS*1000000+S)*1000000+US; 127 | false -> 128 | erlang:error(badarg, [Modifiers]) 129 | end. 130 | 131 | monitor(Type, Item) -> 132 | try 133 | erlang:monitor(Type, Item) 134 | catch 135 | error:Error -> 136 | case {Error, Type, Item} of 137 | {badarg, time_offset, clock_service} -> 138 | %% Time offset is final and will never change. 139 | %% Return a dummy reference, there will never 140 | %% be any need for 'CHANGE' messages... 141 | make_ref(); 142 | _ -> 143 | erlang:error(Error, [Type, Item]) 144 | end 145 | end. 146 | 147 | system_info(Item) -> 148 | try 149 | erlang:system_info(Item) 150 | catch 151 | error:badarg -> 152 | case Item of 153 | time_correction -> 154 | case erlang:system_info(tolerant_timeofday) of 155 | enabled -> true; 156 | disabled -> false 157 | end; 158 | time_warp_mode -> 159 | no_time_warp; 160 | time_offset -> 161 | final; 162 | NotSupArg when NotSupArg == os_monotonic_time_source; 163 | NotSupArg == os_system_time_source; 164 | NotSupArg == start_time; 165 | NotSupArg == end_time -> 166 | %% Cannot emulate this... 167 | erlang:error(notsup, [NotSupArg]); 168 | _ -> 169 | erlang:error(badarg, [Item]) 170 | end; 171 | error:Error -> 172 | erlang:error(Error, [Item]) 173 | end. 174 | 175 | system_flag(Flag, Value) -> 176 | try 177 | erlang:system_flag(Flag, Value) 178 | catch 179 | error:Error -> 180 | case {Error, Flag, Value} of 181 | {badarg, time_offset, finalize} -> 182 | %% Time offset is final 183 | final; 184 | _ -> 185 | erlang:error(Error, [Flag, Value]) 186 | end 187 | end. 188 | 189 | %% 190 | %% Internal functions 191 | %% 192 | 193 | integer_time_unit(native) -> 1000*1000; 194 | integer_time_unit(nano_seconds) -> 1000*1000*1000; 195 | integer_time_unit(micro_seconds) -> 1000*1000; 196 | integer_time_unit(milli_seconds) -> 1000; 197 | integer_time_unit(seconds) -> 1; 198 | integer_time_unit(I) when is_integer(I), I > 0 -> I; 199 | integer_time_unit(BadRes) -> erlang:error(badarg, [BadRes]). 200 | 201 | erlang_system_time_fallback() -> 202 | {MS, S, US} = erlang:now(), 203 | (MS*1000000+S)*1000000+US. 204 | 205 | os_system_time_fallback() -> 206 | {MS, S, US} = os:timestamp(), 207 | (MS*1000000+S)*1000000+US. 208 | 209 | convert_time_unit_fallback(Time, FromUnit, ToUnit) -> 210 | FU = integer_time_unit(FromUnit), 211 | TU = integer_time_unit(ToUnit), 212 | case Time < 0 of 213 | true -> TU*Time - (FU - 1); 214 | false -> TU*Time 215 | end div FU. 216 | 217 | is_valid_modifier_list([positive|Ms]) -> 218 | is_valid_modifier_list(Ms); 219 | is_valid_modifier_list([monotonic|Ms]) -> 220 | is_valid_modifier_list(Ms); 221 | is_valid_modifier_list([]) -> 222 | true; 223 | is_valid_modifier_list(_) -> 224 | false. 225 | -else. 226 | monotonic_time() -> 227 | erlang:monotonic_time(). 228 | 229 | monotonic_time(Unit) -> 230 | erlang:monotonic_time(Unit). 231 | 232 | system_time() -> 233 | erlang:system_time(). 234 | 235 | system_time(Unit) -> 236 | erlang:system_time(Unit). 237 | 238 | os_system_time() -> 239 | os:system_time(). 240 | 241 | os_system_time(Unit) -> 242 | os:system_time(Unit). 243 | 244 | time_offset() -> 245 | erlang:time_offset(). 246 | 247 | time_offset(Unit) -> 248 | erlang:time_offset(Unit). 249 | 250 | convert_time_unit(Time, FromUnit, ToUnit) -> 251 | erlang:convert_time_unit(Time, FromUnit, ToUnit). 252 | 253 | timestamp() -> 254 | erlang:timestamp(). 255 | 256 | unique_timestamp() -> 257 | {MS, S, _} = erlang:timestamp(), 258 | {MS, S, erlang:unique_integer([positive, monotonic])}. 259 | 260 | unique_integer() -> 261 | erlang:unique_integer(). 262 | 263 | unique_integer(Modifiers) -> 264 | erlang:unique_integer(Modifiers). 265 | 266 | monitor(Type, Item) -> 267 | erlang:monitor(Type, Item). 268 | 269 | system_info(Item) -> 270 | erlang:system_info(Item). 271 | 272 | system_flag(Flag, Value) -> 273 | erlang:system_flag(Flag, Value). 274 | 275 | -endif. 276 | -------------------------------------------------------------------------------- /src/p1_utils.app.src: -------------------------------------------------------------------------------- 1 | {application, p1_utils, 2 | [ 3 | {description, "Erlang utility modules from ProcessOne"}, 4 | {vsn, "1.0.27"}, 5 | {modules, []}, 6 | {registered, []}, 7 | {applications, [ 8 | kernel, 9 | stdlib, 10 | inets, 11 | tools, 12 | compiler, 13 | crypto 14 | ]}, 15 | {env, []}, 16 | {mod, {p1_utils, []}}, 17 | 18 | %% hex.pm packaging: 19 | {licenses, ["Apache 2.0"]}, 20 | {links, [{"Github", "https://github.com/processone/p1_utils"}]} 21 | ]}. 22 | -------------------------------------------------------------------------------- /src/p1_utils.erl: -------------------------------------------------------------------------------- 1 | %%%------------------------------------------------------------------- 2 | %%% @author Evgeny Khramtsov 3 | %%% @copyright (C) 2017-2025 Evgeny Khramtsov 4 | %%% @doc 5 | %%% 6 | %%% @end 7 | %%% Created : 8 Mar 2017 by Evgeny Khramtsov 8 | %%%------------------------------------------------------------------- 9 | -module(p1_utils). 10 | 11 | -behaviour(application). 12 | 13 | %% Application callbacks 14 | -export([start/2, stop/1]). 15 | -export([start/0, stop/0]). 16 | 17 | %%%=================================================================== 18 | %%% Application callbacks 19 | %%%=================================================================== 20 | start(_StartType, _StartArgs) -> 21 | case p1_utils_sup:start_link() of 22 | {ok, Pid} -> 23 | {ok, Pid}; 24 | Error -> 25 | Error 26 | end. 27 | 28 | stop(_State) -> 29 | ok. 30 | 31 | %%%=================================================================== 32 | %%% API 33 | %%%=================================================================== 34 | start() -> 35 | case application:ensure_all_started(p1_utils) of 36 | {ok, _} -> ok; 37 | Err -> Err 38 | end. 39 | 40 | stop() -> 41 | application:stop(p1_utils). 42 | -------------------------------------------------------------------------------- /src/p1_utils_sup.erl: -------------------------------------------------------------------------------- 1 | %%%------------------------------------------------------------------- 2 | %%% @author Evgeny Khramtsov 3 | %%% @copyright (C) 2017-2025 Evgeny Khramtsov 4 | %%% @doc 5 | %%% 6 | %%% @end 7 | %%% Created : 8 Mar 2017 by Evgeny Khramtsov 8 | %%%------------------------------------------------------------------- 9 | -module(p1_utils_sup). 10 | 11 | -behaviour(supervisor). 12 | 13 | %% API 14 | -export([start_link/0]). 15 | 16 | %% Supervisor callbacks 17 | -export([init/1]). 18 | 19 | -define(SERVER, ?MODULE). 20 | 21 | %%%=================================================================== 22 | %%% API functions 23 | %%%=================================================================== 24 | start_link() -> 25 | supervisor:start_link({local, ?SERVER}, ?MODULE, []). 26 | 27 | %%%=================================================================== 28 | %%% Supervisor callbacks 29 | %%%=================================================================== 30 | init([]) -> 31 | {ok, {{one_for_one, 10, 1}, []}}. 32 | 33 | %%%=================================================================== 34 | %%% Internal functions 35 | %%%=================================================================== 36 | -------------------------------------------------------------------------------- /src/treap.erl: -------------------------------------------------------------------------------- 1 | %%%---------------------------------------------------------------------- 2 | %%% File : treap.erl 3 | %%% Author : Alexey Shchepin 4 | %%% Purpose : Treaps implementation 5 | %%% Created : 22 Apr 2008 by Alexey Shchepin 6 | %%% 7 | %%% 8 | %%% Copyright (C) 2002-2025 ProcessOne, SARL. All Rights Reserved. 9 | %%% 10 | %%% Licensed under the Apache License, Version 2.0 (the "License"); 11 | %%% you may not use this file except in compliance with the License. 12 | %%% You may obtain a copy of the License at 13 | %%% 14 | %%% http://www.apache.org/licenses/LICENSE-2.0 15 | %%% 16 | %%% Unless required by applicable law or agreed to in writing, software 17 | %%% distributed under the License is distributed on an "AS IS" BASIS, 18 | %%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 19 | %%% See the License for the specific language governing permissions and 20 | %%% limitations under the License. 21 | %%% 22 | %%%---------------------------------------------------------------------- 23 | 24 | -module(treap). 25 | 26 | -export([empty/0, insert/4, delete/2, delete_root/1, 27 | get_root/1, lookup/2, is_empty/1, fold/3, from_list/1, 28 | to_list/1, delete_higher_priorities/2, 29 | priority_from_current_time/0, priority_from_current_time/1]). 30 | 31 | -type hashkey() :: {non_neg_integer(), any()}. 32 | 33 | -type treap() :: {hashkey(), any(), any(), treap(), treap()} | nil. 34 | 35 | -export_type([treap/0]). 36 | 37 | empty() -> nil. 38 | 39 | insert(Key, Priority, Value, Tree) -> 40 | HashKey = {erlang:phash2(Key), Key}, 41 | insert1(Tree, HashKey, Priority, Value). 42 | 43 | insert1(nil, HashKey, Priority, Value) -> 44 | {HashKey, Priority, Value, nil, nil}; 45 | insert1({HashKey1, Priority1, Value1, Left, Right} = 46 | Tree, 47 | HashKey, Priority, Value) -> 48 | if HashKey < HashKey1 -> 49 | heapify({HashKey1, Priority1, Value1, 50 | insert1(Left, HashKey, Priority, Value), Right}); 51 | HashKey > HashKey1 -> 52 | heapify({HashKey1, Priority1, Value1, Left, 53 | insert1(Right, HashKey, Priority, Value)}); 54 | Priority == Priority1 -> 55 | {HashKey, Priority, Value, Left, Right}; 56 | true -> 57 | insert1(delete_root(Tree), HashKey, Priority, Value) 58 | end. 59 | 60 | heapify({_HashKey, _Priority, _Value, nil, nil} = 61 | Tree) -> 62 | Tree; 63 | heapify({HashKey, Priority, Value, nil = Left, 64 | {HashKeyR, PriorityR, ValueR, LeftR, RightR}} = 65 | Tree) -> 66 | if PriorityR > Priority -> 67 | {HashKeyR, PriorityR, ValueR, 68 | {HashKey, Priority, Value, Left, LeftR}, RightR}; 69 | true -> Tree 70 | end; 71 | heapify({HashKey, Priority, Value, 72 | {HashKeyL, PriorityL, ValueL, LeftL, RightL}, 73 | nil = Right} = 74 | Tree) -> 75 | if PriorityL > Priority -> 76 | {HashKeyL, PriorityL, ValueL, LeftL, 77 | {HashKey, Priority, Value, RightL, Right}}; 78 | true -> Tree 79 | end; 80 | heapify({HashKey, Priority, Value, 81 | {HashKeyL, PriorityL, ValueL, LeftL, RightL} = Left, 82 | {HashKeyR, PriorityR, ValueR, LeftR, RightR} = Right} = 83 | Tree) -> 84 | if PriorityR > Priority -> 85 | {HashKeyR, PriorityR, ValueR, 86 | {HashKey, Priority, Value, Left, LeftR}, RightR}; 87 | PriorityL > Priority -> 88 | {HashKeyL, PriorityL, ValueL, LeftL, 89 | {HashKey, Priority, Value, RightL, Right}}; 90 | true -> Tree 91 | end. 92 | 93 | delete(Key, Tree) -> 94 | HashKey = {erlang:phash2(Key), Key}, 95 | delete1(HashKey, Tree). 96 | 97 | delete1(_HashKey, nil) -> nil; 98 | delete1(HashKey, 99 | {HashKey1, Priority1, Value1, Left, Right} = Tree) -> 100 | if HashKey < HashKey1 -> 101 | {HashKey1, Priority1, Value1, delete1(HashKey, Left), 102 | Right}; 103 | HashKey > HashKey1 -> 104 | {HashKey1, Priority1, Value1, Left, 105 | delete1(HashKey, Right)}; 106 | true -> delete_root(Tree) 107 | end. 108 | 109 | delete_root({HashKey, Priority, Value, Left, Right}) -> 110 | case {Left, Right} of 111 | {nil, nil} -> nil; 112 | {_, nil} -> Left; 113 | {nil, _} -> Right; 114 | {{HashKeyL, PriorityL, ValueL, LeftL, RightL}, 115 | {HashKeyR, PriorityR, ValueR, LeftR, RightR}} -> 116 | if PriorityL > PriorityR -> 117 | {HashKeyL, PriorityL, ValueL, LeftL, 118 | delete_root({HashKey, Priority, Value, RightL, Right})}; 119 | true -> 120 | {HashKeyR, PriorityR, ValueR, 121 | delete_root({HashKey, Priority, Value, Left, LeftR}), 122 | RightR} 123 | end 124 | end. 125 | 126 | delete_higher_priorities(Treap, DeletePriority) -> 127 | case treap:is_empty(Treap) of 128 | true -> Treap; 129 | false -> 130 | {_Key, Priority, _Value} = treap:get_root(Treap), 131 | if Priority > DeletePriority -> 132 | delete_higher_priorities(treap:delete_root(Treap), DeletePriority); 133 | true -> Treap 134 | end 135 | end. 136 | 137 | priority_from_current_time() -> 138 | priority_from_current_time(0). 139 | 140 | -ifdef(NEED_TIME_FALLBACKS). 141 | 142 | priority_from_current_time(MsOffset) -> 143 | {MS, S, US} = now(), 144 | -((MS*1000000+S)*1000000+US) + MsOffset. 145 | 146 | -else. 147 | 148 | priority_from_current_time(MsOffset) -> 149 | case MsOffset of 150 | 0 -> 151 | {-erlang:monotonic_time(micro_seconds), -erlang:unique_integer([positive])}; 152 | _ -> 153 | {-erlang:monotonic_time(micro_seconds) + MsOffset, 0} 154 | end. 155 | 156 | -endif. 157 | 158 | is_empty(nil) -> true; 159 | is_empty({_HashKey, _Priority, _Value, _Left, 160 | _Right}) -> 161 | false. 162 | 163 | get_root({{_Hash, Key}, Priority, Value, _Left, 164 | _Right}) -> 165 | {Key, Priority, Value}. 166 | 167 | lookup(Key, Tree) -> 168 | HashKey = {erlang:phash2(Key), Key}, 169 | lookup1(Tree, HashKey). 170 | 171 | lookup1(nil, _HashKey) -> error; 172 | lookup1({HashKey1, Priority1, Value1, Left, Right}, 173 | HashKey) -> 174 | if HashKey < HashKey1 -> lookup1(Left, HashKey); 175 | HashKey > HashKey1 -> lookup1(Right, HashKey); 176 | true -> {ok, Priority1, Value1} 177 | end. 178 | 179 | fold(_F, Acc, nil) -> Acc; 180 | fold(F, Acc, 181 | {{_Hash, Key}, Priority, Value, Left, Right}) -> 182 | Acc1 = F({Key, Priority, Value}, Acc), 183 | Acc2 = fold(F, Acc1, Left), 184 | fold(F, Acc2, Right). 185 | 186 | to_list(Tree) -> to_list(Tree, []). 187 | 188 | to_list(nil, Acc) -> Acc; 189 | to_list(Tree, Acc) -> 190 | Root = get_root(Tree), 191 | to_list(delete_root(Tree), [Root | Acc]). 192 | 193 | from_list(List) -> from_list(List, nil). 194 | 195 | from_list([{Key, Priority, Value} | Tail], Tree) -> 196 | from_list(Tail, insert(Key, Priority, Value, Tree)); 197 | from_list([], Tree) -> Tree. 198 | -------------------------------------------------------------------------------- /test/p1_queue_test.erl: -------------------------------------------------------------------------------- 1 | %%%------------------------------------------------------------------- 2 | %%% @author Evgeny Khramtsov 3 | %%% @copyright (C) 2017-2025 Evgeny Khramtsov 4 | %%% @doc 5 | %%% 6 | %%% @end 7 | %%% Created : 9 Mar 2017 by Evgeny Khramtsov 8 | %%%------------------------------------------------------------------- 9 | -module(p1_queue_test). 10 | 11 | -compile(export_all). 12 | 13 | -include_lib("eunit/include/eunit.hrl"). 14 | -include("p1_queue.hrl"). 15 | 16 | queue_dir() -> 17 | {ok, Cwd} = file:get_cwd(), 18 | filename:join(Cwd, "p1_queue"). 19 | 20 | eacces_dir() -> 21 | {ok, Cwd} = file:get_cwd(), 22 | filename:join(Cwd, "eacces_queue"). 23 | 24 | mk_list() -> 25 | mk_list(1, 10). 26 | 27 | mk_list(From, To) -> 28 | lists:seq(From, To). 29 | 30 | start_test() -> 31 | ?assertEqual(ok, p1_queue:start(queue_dir())). 32 | 33 | double_start_test() -> 34 | ?assertEqual(ok, p1_queue:start(queue_dir())). 35 | 36 | new_ram_test() -> 37 | p1_queue:new(). 38 | new_file_test() -> 39 | Q = p1_queue:new(file), 40 | ?assertEqual(ok, p1_file_queue:close(Q)). 41 | 42 | double_close_test() -> 43 | Q = p1_queue:new(file), 44 | ?assertEqual(ok, p1_file_queue:close(Q)), 45 | ?assertEqual(ok, p1_file_queue:close(Q)). 46 | 47 | close_test() -> 48 | Q1 = p1_queue:new(file), 49 | Q2 = p1_queue:new(file), 50 | ?assertEqual(ok, p1_file_queue:close(Q1)), 51 | ?assertEqual(ok, p1_file_queue:close(Q2)). 52 | 53 | type_ram_test() -> 54 | Q = p1_queue:new(ram), 55 | ?assertEqual(ram, p1_queue:type(Q)). 56 | type_file_test() -> 57 | Q = p1_queue:new(file), 58 | ?assertMatch({file, _}, p1_queue:type(Q)), 59 | ?assertEqual(ok, p1_file_queue:close(Q)). 60 | 61 | is_queue_ram_test() -> 62 | Q = p1_queue:new(ram), 63 | ?assertEqual(true, p1_queue:is_queue(Q)). 64 | is_queue_file_test() -> 65 | Q = p1_queue:new(file), 66 | ?assertEqual(true, p1_queue:is_queue(Q)), 67 | ?assertEqual(ok, p1_file_queue:close(Q)). 68 | 69 | is_queue_not_queue_test() -> 70 | ?assertEqual(false, p1_queue:is_queue(some)). 71 | 72 | from_list_ram_test() -> 73 | L = mk_list(), 74 | Q = p1_queue:from_list(L), 75 | ?assertEqual(ram, p1_queue:type(Q)). 76 | from_list_file_test() -> 77 | L = mk_list(), 78 | Q = p1_queue:from_list(L, file), 79 | ?assertMatch({file, _}, p1_queue:type(Q)), 80 | ?assertEqual(ok, p1_file_queue:close(Q)). 81 | 82 | to_list_ram_test() -> 83 | L = mk_list(), 84 | Q = p1_queue:from_list(L, ram), 85 | ?assertEqual(L, p1_queue:to_list(Q)). 86 | to_list_file_test() -> 87 | L = mk_list(), 88 | Q = p1_queue:from_list(L, file), 89 | ?assertEqual(L, p1_queue:to_list(Q)), 90 | ?assertEqual(ok, p1_file_queue:close(Q)). 91 | 92 | len_ram_test() -> 93 | L = mk_list(), 94 | Q = p1_queue:from_list(L, ram), 95 | ?assertEqual(10, p1_queue:len(Q)). 96 | len_file_test() -> 97 | L = mk_list(), 98 | Q = p1_queue:from_list(L, file), 99 | ?assertEqual(10, p1_queue:len(Q)), 100 | ?assertEqual(ok, p1_file_queue:close(Q)). 101 | 102 | len_macro_ram_test() -> 103 | L = mk_list(), 104 | Q = p1_queue:from_list(L, ram), 105 | ?assertMatch(X when ?qlen(X) == 10, Q). 106 | len_macro_file_test() -> 107 | L = mk_list(), 108 | Q = p1_queue:from_list(L, file), 109 | ?assertMatch(X when ?qlen(X) == 10, Q), 110 | ?assertEqual(ok, p1_file_queue:close(Q)). 111 | 112 | is_empty_ram_test() -> 113 | Q = p1_queue:new(ram), 114 | ?assertEqual(true, p1_queue:is_empty(Q)). 115 | is_empty_file_test() -> 116 | Q = p1_queue:new(file), 117 | ?assertEqual(true, p1_queue:is_empty(Q)), 118 | ?assertEqual(ok, p1_file_queue:close(Q)). 119 | 120 | clear_ram_test() -> 121 | L = mk_list(), 122 | Q = p1_queue:from_list(L, ram), 123 | Q1 = p1_queue:clear(Q), 124 | ?assertEqual(true, p1_queue:is_empty(Q1)). 125 | clear_file_test() -> 126 | L = mk_list(), 127 | Q = p1_queue:from_list(L, file), 128 | Q1 = p1_queue:clear(Q), 129 | ?assertEqual(true, p1_queue:is_empty(Q1)), 130 | ?assertEqual(ok, p1_file_queue:close(Q1)). 131 | 132 | in_ram_test() -> 133 | Q = p1_queue:new(ram), 134 | Q1 = p1_queue:in(1, Q), 135 | ?assertEqual([1], p1_queue:to_list(Q1)). 136 | in_file_test() -> 137 | Q = p1_queue:new(file), 138 | Q1 = p1_queue:in(1, Q), 139 | ?assertEqual([1], p1_queue:to_list(Q1)), 140 | ?assertEqual(ok, p1_file_queue:close(Q1)). 141 | 142 | out_ram_test() -> 143 | Q = p1_queue:new(ram), 144 | Q1 = p1_queue:in(1, Q), 145 | ?assertMatch({{value, 1}, Q}, p1_queue:out(Q1)). 146 | out_file_test() -> 147 | Q = p1_queue:new(file), 148 | Q1 = p1_queue:in(1, Q), 149 | ?assertMatch({{value, 1}, Q2} when ?qlen(Q2) == 0, p1_queue:out(Q1)), 150 | ?assertEqual(ok, p1_file_queue:close(Q1)). 151 | 152 | out_empty_ram_test() -> 153 | Q = p1_queue:new(ram), 154 | ?assertMatch({empty, Q}, p1_queue:out(Q)). 155 | out_empty_file_test() -> 156 | Q = p1_queue:new(file), 157 | ?assertMatch({empty, Q}, p1_queue:out(Q)), 158 | ?assertEqual(ok, p1_file_queue:close(Q)). 159 | 160 | clear_in_test() -> 161 | Q = p1_queue:from_list([1], file), 162 | Q1 = p1_queue:drop(Q), 163 | Q2 = p1_queue:in(2, Q1), 164 | ?assertEqual([2], p1_queue:to_list(Q2)), 165 | ?assertEqual(ok, p1_file_queue:close(Q2)). 166 | 167 | get_limit_ram_test() -> 168 | Q = p1_queue:from_list(mk_list(), ram, 10), 169 | ?assertEqual(10, p1_queue:get_limit(Q)), 170 | ?assertError(full, p1_queue:in(11, Q)). 171 | get_limit_file_test() -> 172 | Q = p1_queue:from_list(mk_list(), file, 10), 173 | ?assertEqual(10, p1_queue:get_limit(Q)), 174 | ?assertError(full, p1_queue:in(11, Q)), 175 | ?assertEqual(ok, p1_file_queue:close(Q)). 176 | 177 | set_limit_ram_test() -> 178 | Q = p1_queue:new(ram), 179 | ?assertEqual(unlimited, p1_queue:get_limit(Q)), 180 | Q1 = p1_queue:set_limit(Q, 10), 181 | ?assertEqual(10, p1_queue:get_limit(Q1)). 182 | set_limit_file_test() -> 183 | Q = p1_queue:new(file), 184 | ?assertEqual(unlimited, p1_queue:get_limit(Q)), 185 | Q1 = p1_queue:set_limit(Q, 10), 186 | ?assertEqual(10, p1_queue:get_limit(Q1)), 187 | ?assertEqual(ok, p1_file_queue:close(Q)). 188 | 189 | from_list_limit_ram_test() -> 190 | ?assertError(full, p1_queue:from_list(mk_list(), ram, 9)). 191 | from_list_limit_file_test() -> 192 | ?assertError(full, p1_queue:from_list(mk_list(), file, 9)). 193 | 194 | peek_ram_test() -> 195 | Q = p1_queue:from_list([1], ram), 196 | ?assertEqual({value, 1}, p1_queue:peek(Q)). 197 | peek_file_test() -> 198 | Q = p1_queue:from_list([1], file), 199 | ?assertEqual({value, 1}, p1_queue:peek(Q)), 200 | ?assertEqual(ok, p1_file_queue:close(Q)). 201 | 202 | peek_empty_ram_test() -> 203 | Q = p1_queue:new(ram), 204 | ?assertEqual(empty, p1_queue:peek(Q)). 205 | peek_empty_file_test() -> 206 | Q = p1_queue:new(file), 207 | ?assertEqual(empty, p1_queue:peek(Q)), 208 | ?assertEqual(ok, p1_file_queue:close(Q)). 209 | 210 | drop_ram_test() -> 211 | Q = p1_queue:new(ram), 212 | Q1 = p1_queue:in(1, Q), 213 | ?assertEqual(Q, p1_queue:drop(Q1)). 214 | drop_file_test() -> 215 | Q = p1_queue:new(file), 216 | Q1 = p1_queue:in(1, Q), 217 | ?assertMatch(Q2 when ?qlen(Q2) == 0, p1_queue:drop(Q1)), 218 | ?assertEqual(ok, p1_file_queue:close(Q1)). 219 | 220 | drop_empty_ram_test() -> 221 | Q = p1_queue:new(ram), 222 | ?assertError(empty, p1_queue:drop(Q)). 223 | drop_empty_file_test() -> 224 | Q = p1_queue:new(file), 225 | ?assertError(empty, p1_queue:drop(Q)), 226 | ?assertEqual(ok, p1_file_queue:close(Q)). 227 | 228 | foreach_ram_test() -> 229 | L = mk_list(), 230 | Q = p1_queue:from_list(L, ram), 231 | put(p1_queue, []), 232 | F = fun(X) -> put(p1_queue, get(p1_queue) ++ [X]) end, 233 | ?assertEqual(ok, p1_queue:foreach(F, Q)), 234 | ?assertEqual(L, get(p1_queue)). 235 | foreach_file_test() -> 236 | L = mk_list(), 237 | Q = p1_queue:from_list(L, file), 238 | put(p1_queue, []), 239 | F = fun(X) -> put(p1_queue, get(p1_queue) ++ [X]) end, 240 | ?assertEqual(ok, p1_queue:foreach(F, Q)), 241 | ?assertEqual(L, get(p1_queue)), 242 | ?assertEqual(ok, p1_file_queue:close(Q)). 243 | 244 | foldl_ram_test() -> 245 | L = mk_list(), 246 | Q = p1_queue:from_list(L, ram), 247 | F = fun(X, Acc) -> Acc ++ [X] end, 248 | ?assertEqual(L, p1_queue:foldl(F, [], Q)). 249 | foldl_file_test() -> 250 | L = mk_list(), 251 | Q = p1_queue:from_list(L, file), 252 | F = fun(X, Acc) -> Acc ++ [X] end, 253 | ?assertEqual(L, p1_queue:foldl(F, [], Q)), 254 | ?assertEqual(ok, p1_file_queue:close(Q)). 255 | 256 | dropwhile_ram_test() -> 257 | L = mk_list(), 258 | Q = p1_queue:from_list(L, ram), 259 | F = fun(X) -> X < 6 end, 260 | Q1 = p1_queue:dropwhile(F, Q), 261 | ?assertEqual([6,7,8,9,10], p1_queue:to_list(Q1)). 262 | dropwhile_file_test() -> 263 | L = mk_list(), 264 | Q = p1_queue:from_list(L, file), 265 | F = fun(X) -> X < 6 end, 266 | Q1 = p1_queue:dropwhile(F, Q), 267 | ?assertEqual([6,7,8,9,10], p1_queue:to_list(Q1)), 268 | ?assertEqual(ok, p1_file_queue:close(Q1)). 269 | 270 | drop_until_empty_ram_test() -> 271 | L = mk_list(), 272 | Q = p1_queue:from_list(L, ram), 273 | Q1 = p1_queue:dropwhile(fun(_) -> true end, Q), 274 | ?assertEqual(true, p1_queue:is_empty(Q1)). 275 | drop_until_empty_file_test() -> 276 | L = mk_list(), 277 | Q = p1_queue:from_list(L, file), 278 | Q1 = p1_queue:dropwhile(fun(_) -> true end, Q), 279 | ?assertEqual(true, p1_queue:is_empty(Q1)), 280 | ?assertEqual(ok, p1_file_queue:close(Q)). 281 | 282 | ram_to_file_test() -> 283 | L = mk_list(), 284 | RQ = p1_queue:from_list(L, ram), 285 | FQ = p1_queue:ram_to_file(RQ), 286 | ?assertEqual(L, p1_file_queue:to_list(FQ)), 287 | ?assertEqual(FQ, p1_queue:ram_to_file(FQ)), 288 | ?assertEqual(ok, p1_file_queue:close(FQ)). 289 | 290 | file_to_ram_test() -> 291 | L = mk_list(), 292 | FQ = p1_queue:from_list(L, file), 293 | RQ = p1_queue:file_to_ram(FQ), 294 | ?assertEqual(L, p1_queue:to_list(RQ)), 295 | ?assertEqual(RQ, p1_queue:file_to_ram(RQ)), 296 | ?assertEqual(ok, p1_file_queue:close(FQ)). 297 | 298 | not_owner_test() -> 299 | Pid = self(), 300 | Owner = spawn_link( 301 | fun() -> 302 | Q = p1_queue:from_list(mk_list(), file), 303 | Pid ! {Q, p1_file_queue:path(Q)}, 304 | receive stop -> Pid ! stopped end 305 | end), 306 | {Q, Path} = receive M -> M end, 307 | ?assertError({bad_queue, {not_owner, Path}}, p1_queue:in(11, Q)), 308 | ?assertError({bad_queue, {not_owner, Path}}, p1_queue:out(Q)), 309 | ?assertError({bad_queue, {not_owner, Path}}, p1_queue:peek(Q)), 310 | ?assertError({bad_queue, {not_owner, Path}}, p1_queue:drop(Q)), 311 | ?assertError({bad_queue, {not_owner, Path}}, p1_queue:to_list(Q)), 312 | ?assertError({bad_queue, {not_owner, Path}}, p1_queue:clear(Q)), 313 | ?assertError({bad_queue, {not_owner, Path}}, 314 | p1_queue:foreach(fun(_) -> ok end, Q)), 315 | ?assertError({bad_queue, {not_owner, Path}}, 316 | p1_queue:dropwhile(fun(_) -> true end, Q)), 317 | ?assertError({bad_queue, {not_owner, Path}}, 318 | p1_queue:foldl(fun(_, X) -> X end, ok, Q)), 319 | Owner ! stop, 320 | receive stopped -> ok end. 321 | 322 | format_error_test() -> 323 | Path = "/path/to/queue", 324 | PathBin = list_to_binary(Path), 325 | ?assertEqual("foo1234 (" ++ Path ++ ")", 326 | p1_queue:format_error({foo1234, PathBin})), 327 | ?assertNotEqual("not_owner (" ++ Path ++ ")", 328 | p1_queue:format_error({not_owner, PathBin})), 329 | ?assertNotEqual("corrupted (" ++ Path ++ ")", 330 | p1_queue:format_error({corrupted, PathBin})). 331 | 332 | bad_size_test() -> 333 | #file_q{fd = Fd, path = Path} = Q = p1_queue:from_list([1], file), 334 | ?assertMatch({ok, _}, file:position(Fd, 0)), 335 | ?assertEqual(ok, file:truncate(Fd)), 336 | ?assertEqual(ok, file:pwrite(Fd, 0, <<1>>)), 337 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:out(Q)), 338 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:peek(Q)), 339 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:drop(Q)), 340 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:to_list(Q)), 341 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:dropwhile(fun(_) -> true end, Q)), 342 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:foreach(fun(_) -> ok end, Q)), 343 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:foldl(fun(_, _) -> ok end, ok, Q)), 344 | ?assertEqual(ok, p1_file_queue:close(Q)). 345 | 346 | eof_test() -> 347 | #file_q{fd = Fd, path = Path} = Q = p1_queue:from_list([1], file), 348 | ?assertMatch({ok, _}, file:position(Fd, 0)), 349 | ?assertEqual(ok, file:truncate(Fd)), 350 | ?assertEqual(ok, file:pwrite(Fd, 0, <<1:32>>)), 351 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:out(Q)), 352 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:peek(Q)), 353 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:to_list(Q)), 354 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:dropwhile(fun(_) -> true end, Q)), 355 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:foreach(fun(_) -> ok end, Q)), 356 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:foldl(fun(_, _) -> ok end, ok, Q)), 357 | ?assertEqual(ok, p1_file_queue:close(Q)). 358 | 359 | bad_term_test() -> 360 | #file_q{fd = Fd, path = Path} = Q = p1_queue:from_list([1], file), 361 | ?assertMatch({ok, _}, file:position(Fd, 0)), 362 | ?assertEqual(ok, file:truncate(Fd)), 363 | ?assertEqual(ok, file:pwrite(Fd, 0, <<5:32, 1>>)), 364 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:out(Q)), 365 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:peek(Q)), 366 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:to_list(Q)), 367 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:dropwhile(fun(_) -> true end, Q)), 368 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:foreach(fun(_) -> ok end, Q)), 369 | ?assertError({bad_queue, {corrupted, Path}}, p1_queue:foldl(fun(_, _) -> ok end, ok, Q)), 370 | ?assertEqual(ok, p1_file_queue:close(Q)). 371 | 372 | closed_test() -> 373 | #file_q{path = Path} = Q = p1_queue:from_list([1], file), 374 | ?assertEqual(ok, p1_file_queue:close(Q)), 375 | ?assertError({bad_queue, {einval, Path}}, p1_queue:in(2, Q)), 376 | ?assertError({bad_queue, {einval, Path}}, p1_queue:out(Q)), 377 | ?assertError({bad_queue, {einval, Path}}, p1_queue:peek(Q)), 378 | ?assertError({bad_queue, {einval, Path}}, p1_queue:drop(Q)), 379 | ?assertError({bad_queue, {einval, Path}}, p1_queue:to_list(Q)), 380 | ?assertError({bad_queue, {einval, Path}}, p1_queue:dropwhile(fun(_) -> true end, Q)), 381 | ?assertError({bad_queue, {einval, Path}}, p1_queue:foreach(fun(_) -> ok end, Q)), 382 | ?assertError({bad_queue, {einval, Path}}, p1_queue:foldl(fun(_, _) -> ok end, ok, Q)), 383 | ?assertError({bad_queue, {einval, Path}}, p1_file_queue:clear(Q)), 384 | ?assertEqual(ok, p1_file_queue:close(Q)). 385 | 386 | write_fail_test() -> 387 | #file_q{fd = Fd, path = Path} = Q = p1_queue:new(file), 388 | ?assertEqual(ok, file:close(Fd)), 389 | %% Open file in read-only mode, so write operations fail 390 | {ok, NewFd} = file:open(Path, [read, binary, raw]), 391 | Q1 = Q#file_q{fd = NewFd}, 392 | ?assertError({bad_queue, {ebadf, Path}}, p1_queue:in(1, Q1)), 393 | ?assertError({bad_queue, {einval, Path}}, p1_file_queue:clear(Q1)), 394 | ?assertEqual(ok, p1_file_queue:close(Q1)). 395 | 396 | gc_test() -> 397 | Q = p1_queue:from_list(lists:seq(1, 1001), file), 398 | Q1 = p1_queue:dropwhile(fun(X) -> X =< 1000 end, Q), 399 | ?assertMatch(#file_q{head = 1000, tail = 1}, Q1), 400 | %% GC should be called here 401 | Q2 = p1_queue:in(1002, Q1), 402 | ?assertMatch(#file_q{head = 0, tail = 2}, Q2), 403 | ?assertEqual(ok, p1_file_queue:close(Q2)). 404 | 405 | destruction_test() -> 406 | %% Check if drop/1 and out/1 don't destruct original queue 407 | Q = p1_queue:from_list([1], file), 408 | p1_queue:drop(Q), 409 | ?assertMatch({_, _}, p1_queue:out(Q)), 410 | ?assertEqual(true, p1_queue:is_queue(Q)), 411 | ?assertEqual(1, p1_queue:len(Q)), 412 | ?assertEqual(false, p1_queue:is_empty(Q)), 413 | ?assertEqual({value, 1}, p1_queue:peek(Q)), 414 | ?assertEqual([1], p1_queue:to_list(Q)), 415 | ?assertEqual(Q, p1_queue:dropwhile(fun(_) -> false end, Q)), 416 | ?assertEqual([1], p1_queue:foldl(fun(X, Acc) -> [X|Acc] end, [], Q)), 417 | ?assertEqual(ok, p1_queue:foreach(fun(_) -> ok end, Q)), 418 | ?assertEqual(ok, p1_file_queue:close(Q)). 419 | 420 | emfile_test() -> 421 | _ = [p1_queue:new(file) || _ <- lists:seq(1, 10)], 422 | ?assertError(emfile, p1_queue:new(file)). 423 | 424 | stop_test() -> 425 | ?assertMatch({ok, [_|_]}, file:list_dir(queue_dir())), 426 | ?assertEqual(ok, p1_queue:stop()), 427 | ?assertEqual({ok, []}, file:list_dir(queue_dir())). 428 | 429 | start_fail_test() -> 430 | Dir = eacces_dir(), 431 | QDir = filename:join(Dir, "p1_queue"), 432 | ?assertEqual(ok, filelib:ensure_dir(QDir)), 433 | ?assertEqual(ok, file:change_mode(Dir, 8#00000)), 434 | ?assertMatch({error, _}, p1_queue:start(QDir)). 435 | 436 | start_eacces_test() -> 437 | ?assertMatch(ok, p1_queue:start(eacces_dir())). 438 | 439 | new_eacces_test() -> 440 | ?assertError({bad_queue, {eacces, _}}, p1_queue:new(file)). 441 | 442 | from_list_eacces_test() -> 443 | L = mk_list(), 444 | ?assertError({bad_queue, {eacces, _}}, p1_queue:from_list(L, file)). 445 | 446 | stop_eaccess_test() -> 447 | ?assertEqual(ok, p1_queue:stop()). 448 | --------------------------------------------------------------------------------