├── .gitignore
├── .hlint.yaml
├── .stylish-haskell.yaml
├── CONTRIBUTING.md
├── ChangeLog.md
├── LICENSE
├── README.md
├── account
├── backend
│ ├── LICENSE
│ ├── rhyolite-account-backend.cabal
│ └── src
│ │ └── Rhyolite
│ │ └── Backend
│ │ ├── Account.hs
│ │ └── Account
│ │ ├── Db.hs
│ │ └── Notify.hs
└── types
│ ├── LICENSE
│ ├── rhyolite-account-types.cabal
│ └── src
│ └── Rhyolite
│ └── Account.hs
├── backend
├── Rhyolite
│ └── Backend
│ │ ├── App.hs
│ │ └── WebSocket.hs
└── rhyolite-backend.cabal
├── beam
├── db
│ ├── LICENSE
│ ├── rhyolite-beam-db.cabal
│ └── src
│ │ └── Rhyolite
│ │ └── DB
│ │ ├── Beam.hs
│ │ └── Beam
│ │ └── Types.hs
├── orphans
│ ├── LICENSE
│ ├── rhyolite-beam-orphans.cabal
│ └── src
│ │ └── Rhyolite
│ │ └── DB
│ │ └── Beam
│ │ └── Orphans.hs
└── task
│ ├── backend
│ ├── LICENSE
│ ├── rhyolite-beam-task-worker-backend.cabal
│ ├── src
│ │ └── Rhyolite
│ │ │ └── Task
│ │ │ └── Beam
│ │ │ └── Worker.hs
│ └── test
│ │ ├── Test.hs
│ │ ├── Types.hs
│ │ └── Utils.hs
│ └── types
│ ├── LICENSE
│ ├── rhyolite-beam-task-worker-types.cabal
│ └── src
│ └── Rhyolite
│ └── Task
│ └── Beam.hs
├── cabal.project
├── common
├── Data
│ └── Vessel
│ │ └── Void.hs
├── Rhyolite
│ ├── Aeson
│ │ └── Orphans.hs
│ ├── Api.hs
│ ├── App.hs
│ ├── Concurrent.hs
│ ├── Route.hs
│ ├── Vessel
│ │ ├── App.hs
│ │ ├── AuthMapV.hs
│ │ ├── AuthenticatedV.hs
│ │ ├── ErrorV.hs
│ │ ├── ErrorV
│ │ │ └── Internal.hs
│ │ ├── Path.hs
│ │ └── Types.hs
│ └── WebSocket.hs
└── rhyolite-common.cabal
├── default.nix
├── dep
├── beam-automigrate
│ ├── default.nix
│ ├── github.json
│ └── thunk.nix
├── bytestring-aeson-orphans
│ ├── default.nix
│ ├── github.json
│ └── thunk.nix
├── default.nix
├── gargoyle
│ ├── default.nix
│ ├── github.json
│ └── thunk.nix
├── monoid-map
│ ├── default.nix
│ ├── github.json
│ └── thunk.nix
├── obelisk
│ ├── default.nix
│ ├── github.json
│ └── thunk.nix
├── postgresql-lo-stream
│ ├── default.nix
│ ├── github.json
│ └── thunk.nix
├── postgresql-simple-interpolate
│ ├── default.nix
│ ├── github.json
│ └── thunk.nix
├── push-notifications
│ ├── default.nix
│ ├── github.json
│ └── thunk.nix
└── vessel
│ ├── default.nix
│ ├── github.json
│ └── thunk.nix
├── email
├── CHANGELOG.md
├── LICENSE
├── email.css
├── mime-mail-orphans
│ ├── LICENSE
│ ├── mime-mail-orphans.cabal
│ └── src
│ │ └── Network
│ │ └── Mail
│ │ └── Mime
│ │ └── Orphans.hs
├── rhyolite-email.cabal
└── src
│ └── Rhyolite
│ ├── Email.hs
│ └── Email
│ └── Orphans.hs
├── frontend
├── Rhyolite
│ └── Frontend
│ │ ├── App.hs
│ │ ├── Auth.hs
│ │ ├── Auth
│ │ └── App.hs
│ │ └── Cookie.hs
└── rhyolite-frontend.cabal
├── gen-docs.sh
├── notify-listen
├── notify-listen-beam
│ ├── CHANGELOG.md
│ ├── LICENSE
│ ├── rhyolite-notify-listen-beam.cabal
│ └── src
│ │ └── Rhyolite
│ │ └── DB
│ │ └── NotifyListen
│ │ └── Beam.hs
└── notify-listen
│ ├── rhyolite-notify-listen.cabal
│ └── src
│ └── Rhyolite
│ └── DB
│ └── NotifyListen.hs
├── psql-extras
├── psql-serializable
│ ├── LICENSE
│ ├── psql-serializable.cabal
│ └── src
│ │ └── Database
│ │ └── PostgreSQL
│ │ └── Serializable.hs
├── psql-simple-beam
│ ├── CHANGELOG.md
│ ├── LICENSE
│ ├── psql-simple-beam.cabal
│ └── src
│ │ └── Database
│ │ └── PostgreSQL
│ │ └── Simple
│ │ └── Beam.hs
└── psql-simple-class
│ ├── CHANGELOG.md
│ ├── LICENSE
│ ├── psql-simple-class.cabal
│ └── src
│ └── Database
│ └── PostgreSQL
│ └── Simple
│ └── Class.hs
├── release.nix
├── rhyolite.svg
├── semimap
├── semimap.cabal
└── src
│ └── Rhyolite
│ └── SemiMap.hs
├── signed-data
├── signed-data-clientsession
│ ├── LICENSE
│ ├── signed-data-clientsession.cabal
│ └── src
│ │ └── Data
│ │ └── Signed
│ │ └── ClientSession.hs
└── signed-data
│ ├── CHANGELOG.md
│ ├── LICENSE
│ ├── signed-data.cabal
│ └── src
│ └── Data
│ └── Signed.hs
├── test
├── rhyolite-test-suite.cabal
└── src-bin
│ └── test.hs
└── widgets
├── CHANGELOG.md
├── LICENSE
├── rhyolite-widgets.cabal
└── src
└── Reflex
└── Dom
└── Widget
├── ExtensibleList.hs
└── Form.hs
/.gitignore:
--------------------------------------------------------------------------------
1 | dist/
2 | dist-newstyle/
3 | result
4 | result-*
5 | *.project.local
6 | .ghc.*
7 | .attr-cache
8 | tags
9 | TAGS
10 | beam/task/backend/psql-test*
11 |
--------------------------------------------------------------------------------
/.hlint.yaml:
--------------------------------------------------------------------------------
1 | # HLint configuration file
2 | # https://github.com/ndmitchell/hlint
3 | ##########################
4 |
5 | # This file contains a template configuration file, which is typically
6 | # placed as .hlint.yaml in the root of your project
7 |
8 |
9 | # Specify additional command line arguments
10 | #
11 | - arguments: [--color, --cpp-simple, -XTypeApplications, -XRecursiveDo]
12 |
13 |
14 | # Control which extensions/flags/modules/functions can be used
15 | #
16 | # - extensions:
17 | # - name: [TypeApplications] # only these listed extensions can be used
18 | # - default: false # all extension are banned by default
19 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
20 | #
21 | # - flags:
22 | # - {name: -w, within: []} # -w is allowed nowhere
23 | #
24 | # - modules:
25 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
26 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely
27 | #
28 | - functions:
29 | - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
30 | - {name: undefined, within: []} # unsafePerformIO can only appear in no modules
31 |
32 |
33 | # Add custom hints for this project
34 | #
35 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
36 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
37 |
38 |
39 | # Turn on hints that are off by default
40 | #
41 | # Ban "module X(module X) where", to require a real export list
42 | # - warn: {name: Use explicit module export list}
43 | #
44 | # Replace a $ b $ c with a . b $ c
45 | # - group: {name: dollar, enabled: true}
46 | #
47 | # Generalise map to fmap, ++ to <>
48 | # - group: {name: generalise, enabled: true}
49 |
50 |
51 | # Ignore some builtin hints
52 | - ignore: {name: Redundant do}
53 | - ignore: {name: Use camelCase}
54 | - ignore: {name: Use if}
55 | - ignore: {name: Use <$>}
56 | - ignore: {name: "Use ?~"}
57 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
58 |
59 |
60 | # Define some custom infix operators
61 | # - fixity: infixr 3 ~^#^~
62 |
63 |
64 | # To generate a suitable file for HLint do:
65 | # $ hlint --default > .hlint.yaml
66 |
--------------------------------------------------------------------------------
/.stylish-haskell.yaml:
--------------------------------------------------------------------------------
1 | # stylish-haskell configuration file
2 | # ==================================
3 |
4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps
5 | # are a list, so they have an order, and one specific step may appear more than
6 | # once (if needed). Each file is processed by these steps in the given order.
7 | steps:
8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled
9 | # by default.
10 | # - unicode_syntax:
11 | # # In order to make this work, we also need to insert the UnicodeSyntax
12 | # # language pragma. If this flag is set to true, we insert it when it's
13 | # # not already present. You may want to disable it if you configure
14 | # # language extensions using some other method than pragmas. Default:
15 | # # true.
16 | # add_language_pragma: true
17 |
18 | # Import cleanup
19 | - imports:
20 | # There are different ways we can align names and lists.
21 | #
22 | # - global: Align the import names and import list throughout the entire
23 | # file.
24 | #
25 | # - file: Like global, but don't add padding when there are no qualified
26 | # imports in the file.
27 | #
28 | # - group: Only align the imports per group (a group is formed by adjacent
29 | # import lines).
30 | #
31 | # - none: Do not perform any alignment.
32 | #
33 | # Default: global.
34 | align: none
35 |
36 | # Folowing options affect only import list alignment.
37 | #
38 | # List align has following options:
39 | #
40 | # - after_alias: Import list is aligned with end of import including
41 | # 'as' and 'hiding' keywords.
42 | #
43 | # > import qualified Data.List as List (concat, foldl, foldr, head,
44 | # > init, last, length)
45 | #
46 | # - with_alias: Import list is aligned with start of alias or hiding.
47 | #
48 | # > import qualified Data.List as List (concat, foldl, foldr, head,
49 | # > init, last, length)
50 | #
51 | # - new_line: Import list starts always on new line.
52 | #
53 | # > import qualified Data.List as List
54 | # > (concat, foldl, foldr, head, init, last, length)
55 | #
56 | # Default: after alias
57 | list_align: after_alias
58 |
59 | # Long list align style takes effect when import is too long. This is
60 | # determined by 'columns' setting.
61 | #
62 | # - inline: This option will put as much specs on same line as possible.
63 | #
64 | # - new_line: Import list will start on new line.
65 | #
66 | # - new_line_multiline: Import list will start on new line when it's
67 | # short enough to fit to single line. Otherwise it'll be multiline.
68 | #
69 | # - multiline: One line per import list entry.
70 | # Type with contructor list acts like single import.
71 | #
72 | # > import qualified Data.Map as M
73 | # > ( empty
74 | # > , singleton
75 | # > , ...
76 | # > , delete
77 | # > )
78 | #
79 | # Default: inline
80 | long_list_align: inline
81 |
82 | # List padding determines indentation of import list on lines after import.
83 | # This option affects 'list_align' and 'long_list_align'.
84 | list_padding: 2
85 |
86 | # Separate lists option affects formating of import list for type
87 | # or class. The only difference is single space between type and list
88 | # of constructors, selectors and class functions.
89 | #
90 | # - true: There is single space between Foldable type and list of it's
91 | # functions.
92 | #
93 | # > import Data.Foldable (Foldable (fold, foldl, foldMap))
94 | #
95 | # - false: There is no space between Foldable type and list of it's
96 | # functions.
97 | #
98 | # > import Data.Foldable (Foldable(fold, foldl, foldMap))
99 | #
100 | # Default: true
101 | separate_lists: true
102 |
103 | # Language pragmas
104 | - language_pragmas:
105 | # We can generate different styles of language pragma lists.
106 | #
107 | # - vertical: Vertical-spaced language pragmas, one per line.
108 | #
109 | # - compact: A more compact style.
110 | #
111 | # - compact_line: Similar to compact, but wrap each line with
112 | # `{-#LANGUAGE #-}'.
113 | #
114 | # Default: vertical.
115 | style: vertical
116 |
117 | # Align affects alignment of closing pragma brackets.
118 | #
119 | # - true: Brackets are aligned in same collumn.
120 | #
121 | # - false: Brackets are not aligned together. There is only one space
122 | # between actual import and closing bracket.
123 | #
124 | # Default: true
125 | align: false
126 |
127 | # stylish-haskell can detect redundancy of some language pragmas. If this
128 | # is set to true, it will remove those redundant pragmas. Default: true.
129 | remove_redundant: true
130 |
131 | # Align the types in record declarations
132 | # - records: {}
133 |
134 | # Replace tabs by spaces. This is disabled by default.
135 | # - tabs:
136 | # # Number of spaces to use for each tab. Default: 8, as specified by the
137 | # # Haskell report.
138 | # spaces: 8
139 |
140 | # Remove trailing whitespace
141 | - trailing_whitespace: {}
142 |
143 | # A common setting is the number of columns (parts of) code will be wrapped
144 | # to. Different steps take this into account. Default: 80.
145 | columns: 110
146 |
147 | # Sometimes, language extensions are specified in a cabal file or from the
148 | # command line instead of using language pragmas in the file. stylish-haskell
149 | # needs to be aware of these, so it can parse the file correctly.
150 | #
151 | # No language extensions are enabled by default.
152 | # language_extensions:
153 | # - TemplateHaskell
154 | # - QuasiQuotes
155 |
--------------------------------------------------------------------------------
/CONTRIBUTING.md:
--------------------------------------------------------------------------------
1 | # Contribution Guide
2 |
3 | Contributions and issue reports are encouraged and appreciated!
4 |
5 | - [Opening Issues](#opening-issues)
6 | - [Submitting Changes](#submitting-changes)
7 | - [Guidelines for Commit Messages](#guidelines-for-commit-messages)
8 | - [Guidelines for Pull Requests](#guidelines-for-pull-requests)
9 | - [Code Quality](#code-quality)
10 | - [Documentation](#documentation)
11 |
12 | ## Opening Issues
13 |
14 | Before opening an issue, please check whether your issue has already been reported. Assuming it has not:
15 |
16 | * Describe the issue you're encountering or the suggestion you're making
17 | * Include any relevant steps to reproduce or code samples you can. It's always easier for us to debug if we have something that demonstrates the error.
18 | * Let us know what version of this project you were using. If you're using a github checkout, provide the git hash.
19 |
20 | ## Submitting Changes
21 |
22 | Most pull requests should target the `develop` branch. `master` is the release branch. `develop` is periodically merged into master after a period of testing.
23 |
24 | ### Guidelines for Commit Messages
25 |
26 | #### Summary Line
27 | The summary line of your commit message should summarize the changes being made. Commit messages should be written in the imperative mood and should describe what happens when the commit is applied. If your commit modifies one of the in-tree haskell packages specifically, please prefix your commit summary with the name of the package being modified.
28 |
29 | One way to think about it is that your commit message should be able to complete the sentence:
30 | "When applied, this commit will..."
31 |
32 | ##### Note on bumping dependencies
33 | Commits that update a dependency should include some information about why the dependency was updated in the commit message.
34 |
35 | #### Body
36 | For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff.
37 |
38 | ### Guidelines for Pull Requests
39 |
40 | Wherever possible, pull requests should add a single feature or fix a single bug. Pull requests should not bundle several unrelated changes.
41 |
42 | ### Code Quality
43 |
44 | #### Warnings
45 |
46 | Your pull request should add no new warnings to the project. It should also generally not disable any warnings.
47 |
48 | #### Build and Test
49 |
50 | Make sure the project builds and that the tests pass! This will generally also be checked by CI before merge, but trying it yourself first means you'll catch problems earlier and your contribution can be merged that much sooner!
51 |
52 | You can run the tests like this:
53 | ```bash
54 | nix-build release.nix
55 | ```
56 |
57 | ### Documentation
58 |
59 | #### In the code
60 | We're always striving to improve documentation. Please include [haddock](https://haskell-haddock.readthedocs.io/en/latest/index.html) documentation for any added code, and update the documentation for any code you modify.
61 |
62 | #### In the [Changelog](ChangeLog.md)
63 | Add an entry to the changelog when your PR:
64 | * Adds a feature
65 | * Deprecates something
66 | * Includes a breaking change
67 | * Makes any other change that will impact users
68 |
69 | #### In the [Readme](README.md)
70 | The readme is the first place a lot of people look for information about the repository. Update any parts of the readme that are affected by your PR.
71 |
72 |
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2018, Obsidian Systems LLC
2 | All rights reserved.
3 |
4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5 |
6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7 |
8 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
9 |
10 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
11 |
12 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
13 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # 
Rhyolite
2 | [](https://github.com/obsidiansystems/obelisk) [](https://haskell.org) [](https://nixos.org) [](https://github.com/obsidiansystems/rhyolite/blob/master/LICENSE)
3 |
4 | Rhyolite is a collection of packages used to jump-start web application
5 | development using Obelisk and reflex.
6 |
7 | Rhyolite provides:
8 | * a client/server communication framework for both request/response APIs and
9 | live-updating queries; and
10 | * a library of types and components commonly used when building a web
11 | application.
12 |
13 | ## Using Rhyolite with an Obelisk project
14 |
15 | 1. Within an already initialized Obelisk project, clone Rhyolite into
16 | the dep directory, if you haven’t already:
17 |
18 | ```bash
19 | git clone https://github.com/obsidiansystems/rhyolite dep/rhyolite
20 | ```
21 |
22 | 1. Add Rhyolite’s haskellOverrides to default.nix so that your package
23 | can access them. This involves adding overrides to the arguments
24 | passed to Obelisk’s project function so that it imports Rhyolite’s
25 | haskellOverrides. You can base it off of this example:
26 |
27 | ```
28 | { system ? builtins.currentSystem, obelisk ? import ./.obelisk/impl {
29 | inherit system;
30 | iosSdkVersion = "13.2";
31 |
32 | # You must accept the Android Software Development Kit License Agreement at
33 | # https://developer.android.com/studio/terms in order to build Android apps.
34 | # Uncomment and set this to `true` to indicate your acceptance:
35 | # config.android_sdk.accept_license = false;
36 |
37 | # In order to use Let's Encrypt for HTTPS deployments you must accept
38 | # their terms of service at https://letsencrypt.org/repository/.
39 | # Uncomment and set this to `true` to indicate your acceptance:
40 | # terms.security.acme.acceptTerms = false;
41 | } }:
42 | with obelisk;
43 | project ./. ({ pkgs, hackGet, ... }@args: {
44 |
45 | overrides = pkgs.lib.composeExtensions
46 | (pkgs.callPackage (hackGet ./dep/rhyolite) args).haskellOverrides
47 | (self: super:
48 | with pkgs.haskell.lib;
49 | {
50 | # Your custom overrides go here.
51 | });
52 |
53 | android.applicationId = "systems.obsidian.obelisk.examples.minimal";
54 | android.displayName = "Obelisk Minimal Example";
55 | ios.bundleIdentifier = "systems.obsidian.obelisk.examples.minimal";
56 | ios.bundleName = "Obelisk Minimal Example";
57 | })
58 | ```
59 |
60 | 1. You can now add any of Rhyolite’s packages as dependencies to your
61 | Obelisk project. The packages Rhyolite provides are listed in [cabal.project](cabal.project).
62 |
63 | ### Alternative method
64 |
65 | You can also let Rhyolite manage Obelisk directly. This is easier to
66 | setup but also means that you are stuck with the Obelisk version used
67 | by Rhyolite.
68 |
69 | To do this, simply overwrite the ```.obelisk/impl/github.json``` file
70 | with this Rhyolite thunk:
71 |
72 | ```
73 | {
74 | "owner": "obsidiansystems",
75 | "repo": "rhyolite",
76 | "branch": "master",
77 | "private": false,
78 | "rev": "9f13d8d8a2233aae54e15c39acf68181893b859a",
79 | "sha256": "1vhbw9bdqpfddavfjfdrq6kk5wwsd8hbgb8pnna9i2db3x3cmzvy"
80 | }
81 | ```
82 |
83 | ## Hacking
84 |
85 | ### Entering a shell
86 |
87 | You can use `nix-shell -A proj.shells.ghc` to enter a shell from which you can build any of the subprojects in this repository. From that shell you can:
88 |
89 | * Enter a shell using `cabal repl /path/to/package`
90 | * Use ghcid by invoking `ghcid -c "cabal repl /path/to/package`
91 | * Build a package using `cabal build /path/to/package`
92 | * Generate haddock documentation using `cabal haddock /path/to/package` (e.g., `cabal haddock notify-listen/notify-listen-beam`)
93 | * Generate a standalone haddock page for all the packages in this repo by running `./gen-docs.sh`
94 |
95 | ### Testing that things build
96 |
97 | Because of the inter-related nature of these packages, `rhyolite-test-suite` tests that all of them can be built against one another. To test, run:
98 |
99 | ```bash
100 | nix-shell -A proj.shells.ghc --run "cabal build test"
101 | ```
102 |
--------------------------------------------------------------------------------
/account/backend/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/account/backend/rhyolite-account-backend.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: rhyolite-account-backend
3 | version: 0.1.0.0
4 | synopsis: Functions for creating and authenticating accounts
5 | homepage: https://github.com/obsidiansystems/rhyolite
6 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
7 | license: BSD-3-Clause
8 | license-file: LICENSE
9 | author: Obsidian Systems LLC
10 | maintainer: maintainer@obsidian.systems
11 | copyright: Obsidian Systems LLC
12 | category: Web
13 |
14 | library
15 | exposed-modules: Rhyolite.Backend.Account
16 | Rhyolite.Backend.Account.Db
17 | Rhyolite.Backend.Account.Notify
18 | build-depends: base
19 | , aeson
20 | , beam-core
21 | , bytestring
22 | , text
23 | , time
24 | , beam-postgres
25 | , rhyolite-account-types
26 | , rhyolite-beam-db
27 | , constraints
28 | , constraints-extras
29 | , pwstore-fast
30 | , transformers
31 | , rhyolite-notify-listen
32 | , rhyolite-notify-listen-beam
33 | , psql-simple-beam
34 | , clientsession
35 | , signed-data
36 | , signed-data-clientsession
37 | hs-source-dirs: src
38 | default-language: Haskell2010
39 |
--------------------------------------------------------------------------------
/account/backend/src/Rhyolite/Backend/Account.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description:
3 | Check or modify credentials
4 | -}
5 | {-# Language DeriveGeneric #-}
6 | {-# Language FlexibleContexts #-}
7 | {-# Language MonoLocalBinds #-}
8 | {-# Language OverloadedStrings #-}
9 | module Rhyolite.Backend.Account
10 | ( createAccount
11 | , ensureAccountExists
12 | , login
13 | , setAccountPassword
14 | , setAccountPasswordHash
15 | , makePasswordHash
16 | , passwordResetToken
17 | , newNonce
18 | , resetPassword
19 | , resetPasswordHash
20 | ) where
21 |
22 | import Rhyolite.Backend.Account.Db hiding (createAccount, ensureAccountExists)
23 | import Rhyolite.Backend.Account.Notify (createAccount, ensureAccountExists)
24 |
--------------------------------------------------------------------------------
/account/backend/src/Rhyolite/Backend/Account/Db.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description:
3 | Create or modify accounts in the database
4 |
5 | This module does not handle notifications. See
6 | Rhyolite.Backend.Account.Notify for that
7 | -}
8 | {-# Language DeriveGeneric #-}
9 | {-# Language FlexibleContexts #-}
10 | {-# Language MonoLocalBinds #-}
11 | {-# Language OverloadedStrings #-}
12 | module Rhyolite.Backend.Account.Db
13 | ( createAccount
14 | , login
15 | , ensureAccountExists
16 | , setAccountPassword
17 | , setAccountPasswordHash
18 | , makePasswordHash
19 | , passwordResetToken
20 | , newNonce
21 | , resetPassword
22 | , resetPasswordHash
23 | ) where
24 |
25 | import Control.Monad (guard)
26 | import Control.Monad.Trans.Maybe
27 | import Crypto.PasswordStore
28 | import Data.ByteString
29 | import Data.Functor.Identity
30 | import Data.Maybe
31 | import Data.Signed
32 | import Data.Signed.ClientSession
33 | import Data.Text
34 | import Data.Text.Encoding (encodeUtf8)
35 | import qualified Data.Text.Encoding as T
36 | import Data.Time
37 | import Database.Beam
38 | import Database.Beam.Backend.SQL.BeamExtensions
39 | import Database.Beam.Postgres
40 | import Database.Beam.Postgres.Full hiding (insert)
41 | import Database.PostgreSQL.Simple.Beam ()
42 | import Rhyolite.Account
43 | import Rhyolite.DB.Beam (current_timestamp_)
44 | import Web.ClientSession as CS
45 |
46 | -- | Creates a new account and emits a db notification about it
47 | createAccount
48 | :: DatabaseEntity Postgres db (TableEntity Account)
49 | -> Text
50 | -> Text
51 | -> Pg (Either Text (PrimaryKey Account Identity))
52 | createAccount accountTable email pass = do
53 | hash <- makePasswordHash pass
54 | accountIds <- runPgInsertReturningList $ flip returning _account_id $ insert accountTable $ insertExpressions
55 | [ Account
56 | { _account_id = default_
57 | , _account_email = lower_ (val_ email)
58 | , _account_password = val_ (Just hash)
59 | , _account_passwordResetNonce = just_ current_timestamp_
60 | }
61 | ]
62 | case accountIds of
63 | [accountId] -> pure $ Right $ AccountId accountId
64 | _ -> pure $ Left "Failed to create account"
65 |
66 | -- | Attempts to login a user given some credentials.
67 | login
68 | :: Database Postgres db
69 | => DatabaseEntity Postgres db (TableEntity Account)
70 | -> Text
71 | -> Text
72 | -> Pg (Maybe (PrimaryKey Account Identity))
73 | login accountTable email pass = runMaybeT $ do
74 | (aid, mPwHash) <- MaybeT $ fmap listToMaybe $ runSelectReturningList $ select $ do
75 | acc <- all_ accountTable
76 | guard_ $ lower_ (_account_email acc) ==. lower_ (val_ email)
77 | pure (_account_id acc, _account_password acc)
78 | pwHash <- MaybeT $ pure mPwHash
79 | guard $ verifyPasswordWith pbkdf2 (2^) (T.encodeUtf8 pass) pwHash
80 | pure (AccountId aid)
81 |
82 | ensureAccountExists
83 | :: (Database Postgres db)
84 | => DatabaseEntity Postgres db (TableEntity Account)
85 | -> Text
86 | -> Pg (Bool, PrimaryKey Account Identity)
87 | ensureAccountExists accountTable email = do
88 | existingAccountId <- runSelectReturningOne $ select $ fmap primaryKey $ filter_ (\x ->
89 | lower_ (_account_email x) ==. lower_ (val_ email)) $ all_ accountTable
90 | case existingAccountId of
91 | Just existing -> return (False, existing)
92 | Nothing -> do
93 | results <- runInsertReturningList $ insert accountTable $ insertExpressions
94 | [ Account
95 | { _account_id = default_
96 | , _account_email = lower_ (val_ email)
97 | , _account_password = nothing_
98 | , _account_passwordResetNonce = nothing_
99 | }
100 | ]
101 | case results of
102 | [acc] -> do
103 | let aid = primaryKey acc
104 | pure (True, aid)
105 | _ -> error "ensureAccountExists: Creating account failed"
106 |
107 | setAccountPassword
108 | :: DatabaseEntity Postgres db (TableEntity Account)
109 | -> PrimaryKey Account Identity
110 | -> Text
111 | -> Pg ()
112 | setAccountPassword tbl aid password = do
113 | pw <- liftIO $ makePasswordHash password
114 | setAccountPasswordHash tbl aid pw
115 |
116 | setAccountPasswordHash
117 | :: DatabaseEntity Postgres db (TableEntity Account)
118 | -> PrimaryKey Account Identity
119 | -> ByteString
120 | -> Pg ()
121 | setAccountPasswordHash accountTable aid hash = runUpdate $ update accountTable
122 | (\x -> mconcat
123 | [ _account_password x <-. val_ (Just hash)
124 | , _account_passwordResetNonce x <-. nothing_
125 | ]
126 | )
127 | (\x -> primaryKey x ==. val_ aid)
128 |
129 | makePasswordHash
130 | :: MonadIO m
131 | => Text
132 | -> m ByteString
133 | makePasswordHash pw = do
134 | salt <- liftIO genSaltIO
135 | return $ makePasswordSaltWith pbkdf2 (2^) (encodeUtf8 pw) salt 19
136 |
137 | resetPassword
138 | :: (Database Postgres db)
139 | => DatabaseEntity Postgres db (TableEntity Account)
140 | -> PrimaryKey Account Identity
141 | -> UTCTime
142 | -> Text
143 | -> Pg (Maybe (PrimaryKey Account Identity))
144 | resetPassword tbl aid t pw = do
145 | hash <- makePasswordHash pw
146 | resetPasswordHash tbl aid t hash
147 |
148 | resetPasswordHash
149 | :: (Database Postgres db)
150 | => DatabaseEntity Postgres db (TableEntity Account)
151 | -> PrimaryKey Account Identity
152 | -> UTCTime
153 | -> ByteString
154 | -> Pg (Maybe (PrimaryKey Account Identity))
155 | resetPasswordHash accountTable aid nonce pwhash = do
156 | macc <- runSelectReturningOne $ lookup_ accountTable aid
157 | case macc of
158 | Nothing -> return Nothing
159 | Just a -> if _account_passwordResetNonce a == Just nonce
160 | then do
161 | setAccountPasswordHash accountTable aid pwhash
162 | return $ Just aid
163 | else fail "nonce mismatch"
164 |
165 | passwordResetToken
166 | :: MonadIO m
167 | => CS.Key
168 | -> PrimaryKey Account Identity
169 | -> UTCTime
170 | -> m (Signed PasswordResetToken)
171 | passwordResetToken csk aid nonce = do
172 | liftIO $ signWithKey csk $ PasswordResetToken (aid, nonce)
173 |
174 | newNonce
175 | :: DatabaseEntity Postgres db (TableEntity Account)
176 | -> PrimaryKey Account Identity
177 | -> Pg (Maybe UTCTime)
178 | newNonce accountTable aid = do
179 | a <- runUpdateReturningList $ update accountTable
180 | (\x -> _account_passwordResetNonce x <-. just_ current_timestamp_)
181 | (\x -> primaryKey x ==. val_ aid)
182 | pure $ case a of
183 | [acc] -> _account_passwordResetNonce acc
184 | _ -> Nothing
185 |
--------------------------------------------------------------------------------
/account/backend/src/Rhyolite/Backend/Account/Notify.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description:
3 | Create or modify accounts in the database, and send LISTEN notifications
4 | -}
5 | {-# Language DeriveGeneric #-}
6 | {-# Language FlexibleContexts #-}
7 | {-# Language MonoLocalBinds #-}
8 | {-# Language OverloadedStrings #-}
9 | module Rhyolite.Backend.Account.Notify
10 | ( createAccount
11 | , login
12 | , ensureAccountExists
13 | , setAccountPassword
14 | , setAccountPasswordHash
15 | , makePasswordHash
16 | , passwordResetToken
17 | , newNonce
18 | , resetPassword
19 | , resetPasswordHash
20 | ) where
21 |
22 | import Data.Aeson
23 | import Data.Constraint.Extras
24 | import Data.Constraint.Forall
25 | import Data.Functor.Identity
26 | import Data.Text
27 | import Database.Beam
28 | import Database.Beam.Postgres
29 | import Database.PostgreSQL.Simple.Beam ()
30 | import Rhyolite.Account
31 | import Rhyolite.Backend.Account.Db hiding (createAccount, ensureAccountExists)
32 | import qualified Rhyolite.Backend.Account.Db as Acc
33 | import Rhyolite.DB.NotifyListen
34 | import Rhyolite.DB.NotifyListen.Beam
35 |
36 | -- | Creates a new account and emits a db notification about it
37 | createAccount
38 | :: (Has' ToJSON notice Identity, ForallF ToJSON notice)
39 | => DatabaseEntity Postgres db (TableEntity Account)
40 | -> notice (PrimaryKey Account Identity)
41 | -> Text
42 | -> Text
43 | -> Pg (Either Text (PrimaryKey Account Identity))
44 | createAccount accountTable noticeWrapper email pass = do
45 | result <- Acc.createAccount accountTable email pass
46 | case result of
47 | Right accountId ->
48 | notify NotificationType_Insert noticeWrapper accountId
49 | _ -> pure ()
50 | pure result
51 |
52 | ensureAccountExists
53 | :: (Database Postgres db, HasNotification n Account, Has' ToJSON n Identity, ForallF ToJSON n)
54 | => DatabaseEntity Postgres db (TableEntity Account)
55 | -> Text
56 | -> Pg (Bool, PrimaryKey Account Identity)
57 | ensureAccountExists accountTable email = do
58 | aid <- Acc.ensureAccountExists accountTable email
59 | notify NotificationType_Insert (notification accountTable) $ snd aid
60 | pure aid
61 |
--------------------------------------------------------------------------------
/account/types/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/account/types/rhyolite-account-types.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: rhyolite-account-types
3 | version: 0.1.0.0
4 | synopsis: Account types for rhyolite apps
5 | homepage: https://github.com/obsidiansystems/rhyolite
6 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
7 | license: BSD-3-Clause
8 | license-file: LICENSE
9 | author: Obsidian Systems LLC
10 | maintainer: maintainer@obsidian.systems
11 | copyright: Obsidian Systems LLC
12 | category: Web
13 |
14 | library
15 | exposed-modules: Rhyolite.Account
16 | build-depends: base
17 | , aeson
18 | , beam-core
19 | , bytestring
20 | , text
21 | , time
22 | hs-source-dirs: src
23 | default-language: Haskell2010
24 |
--------------------------------------------------------------------------------
/account/types/src/Rhyolite/Account.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description:
3 | Default email-based account type
4 | -}
5 | {-# Language DeriveGeneric #-}
6 | {-# Language FlexibleInstances #-}
7 | {-# Language StandaloneDeriving #-}
8 | {-# Language TypeFamilies #-}
9 | module Rhyolite.Account where
10 |
11 | import Data.Aeson
12 | import Data.ByteString (ByteString)
13 | import Data.Functor.Identity
14 | import Data.Int (Int64)
15 | import Data.Text (Text)
16 | import Data.Time (UTCTime)
17 | import Database.Beam.Backend.SQL.Types
18 | import Database.Beam.Schema
19 | import GHC.Generics
20 |
21 | -- | The Account table defines user identities and how to authenticate them
22 | data Account f = Account
23 | { _account_id :: Columnar f (SqlSerial Int64)
24 | , _account_email :: Columnar f Text
25 | , _account_password :: Columnar f (Maybe ByteString)
26 | , _account_passwordResetNonce :: Columnar f (Maybe UTCTime)
27 | } deriving (Generic)
28 |
29 | instance Beamable Account
30 |
31 | instance Table Account where
32 | newtype PrimaryKey Account f = AccountId
33 | { _accountId_id :: Columnar f (SqlSerial Int64)
34 | }
35 | deriving (Generic)
36 | primaryKey = AccountId . _account_id
37 |
38 | instance Beamable (PrimaryKey Account)
39 |
40 | type AccountId = PrimaryKey Account Identity
41 |
42 | deriving instance Eq (PrimaryKey Account Identity)
43 | deriving instance Ord (PrimaryKey Account Identity)
44 | deriving instance Show (PrimaryKey Account Identity)
45 |
46 | instance ToJSON (PrimaryKey Account Identity)
47 | instance FromJSON (PrimaryKey Account Identity)
48 | instance ToJSONKey (PrimaryKey Account Identity)
49 | instance FromJSONKey (PrimaryKey Account Identity)
50 |
51 | newtype PasswordResetToken = PasswordResetToken
52 | { unPasswordResetToken :: (PrimaryKey Account Identity, UTCTime)
53 | }
54 | deriving (Generic)
55 |
56 | instance ToJSON PasswordResetToken
57 | instance FromJSON PasswordResetToken
58 |
--------------------------------------------------------------------------------
/backend/Rhyolite/Backend/WebSocket.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description: Websocket connection, send, and receive
3 |
4 | Setting up the WebSocket connection using 'Snap.Core' and primitives for
5 | getting and setting websocket messages.
6 | -}
7 | module Rhyolite.Backend.WebSocket where
8 |
9 | import Control.Exception (AssertionFailed(..), SomeException(..), handle, throwIO)
10 | import Control.Monad.IO.Class (liftIO)
11 | import Data.Aeson (FromJSON, ToJSON, eitherDecode', encode)
12 | import Data.Semigroup ((<>))
13 | import qualified Network.WebSockets as WS
14 | import qualified Network.WebSockets.Connection as WS
15 | import Network.WebSockets.Snap (runWebSocketsSnap)
16 | import qualified Network.WebSockets.Stream as WS
17 | import Snap.Core (MonadSnap)
18 |
19 | -- | Accepts a websockets connection and runs the supplied action with it using the given logging function
20 | -- when an error occurs.
21 | withWebsocketsConnectionLogging :: MonadSnap m => (String -> SomeException -> IO ()) -> (WS.Connection -> IO ()) -> m ()
22 | withWebsocketsConnectionLogging logger f = runWebSocketsSnap $ withPendingWebsocketConnection logger f
23 |
24 | -- | Like 'withWebsocketsConnectionLogging' but with a default logging function using 'putStrLn'.
25 | withWebsocketsConnection :: MonadSnap m => (WS.Connection -> IO ()) -> m ()
26 | withWebsocketsConnection f = runWebSocketsSnap $ withPendingWebsocketConnection logger f
27 | where
28 | logger str e = putStrLn $ "withWebsocketsConnection: " <> (if null str then "" else str <> ": ") <> show e
29 |
30 | -- | Handle a websocket connection that is in a "pending" state (i.e., that hasn't yet been accepted)
31 | withPendingWebsocketConnection :: (String -> SomeException -> IO ()) -> (WS.Connection -> IO ()) -> WS.PendingConnection -> IO ()
32 | withPendingWebsocketConnection logger f pc = do
33 | conn <- WS.acceptRequest pc
34 | handleSomeException $ handleConnectionException $ f conn
35 | where
36 | handleSomeException = handle $ \e -> logger "" e
37 | handleConnectionException = handle $ \e -> case e of
38 | WS.ConnectionClosed -> return ()
39 | WS.CloseRequest _ _ -> print e >> WS.close (WS.pendingStream pc) >> throwIO e
40 | _ -> logger "Exception" (SomeException e) *> throwIO e
41 |
42 |
43 | -- | Attempts to json decode a websockets data message
44 | decodeWebsocketsDataMessage :: FromJSON a => WS.DataMessage -> Either String a
45 | decodeWebsocketsDataMessage dm = eitherDecode' $ case dm of
46 | WS.Text r' _ -> r'
47 | WS.Binary r' -> r'
48 |
49 | -- | Parse and process a single websocket data message
50 | getDataMessage
51 | :: FromJSON a
52 | => WS.Connection
53 | -> IO a
54 | getDataMessage conn = do
55 | dm <- WS.receiveDataMessage conn
56 | case decodeWebsocketsDataMessage dm of
57 | Left err -> liftIO $ throwIO $ AssertionFailed $ mconcat
58 | [ "getDataMessage: error: "
59 | , err
60 | , "; received: "
61 | , show dm
62 | ]
63 | Right a -> return a
64 |
65 | -- | Send a json encoded data message over the websocket connection
66 | sendEncodedDataMessage
67 | :: ToJSON a
68 | => WS.Connection
69 | -> a
70 | -> IO ()
71 | sendEncodedDataMessage conn = WS.sendDataMessage conn . (\x -> WS.Text x Nothing) . encode
72 |
--------------------------------------------------------------------------------
/backend/rhyolite-backend.cabal:
--------------------------------------------------------------------------------
1 | name: rhyolite-backend
2 | version: 0.1
3 | license: BSD3
4 | copyright: Copyright (C) Obsidian Systems LLC 2018
5 | author: Obsidian Systems LLC
6 | maintainer: maintainer@obsidian.systems
7 | stability: Experimental
8 | build-type: Simple
9 | cabal-version: >=1.2
10 | synopsis: Backend infrastructure to support FRP-based frontends
11 | description:
12 | Rhyolite backends are designed to deliver live-updating data to reflex-powered applications.
13 |
14 | library
15 | hs-source-dirs: .
16 | build-depends:
17 | aeson
18 | , base
19 | , commutative-semigroups
20 | , constraints
21 | , constraints-extras
22 | , lens
23 | , monoid-map
24 | , monoidal-containers
25 | , patch
26 | , postgresql-simple
27 | , reflex
28 | , resource-pool
29 | , rhyolite-common
30 | , rhyolite-notify-listen
31 | , semialign
32 | , signed-data
33 | , signed-data-clientsession
34 | , snap-core
35 | , some
36 | , text
37 | , vessel
38 | , websockets
39 | , websockets-snap
40 | , witherable
41 |
42 | exposed-modules:
43 | Rhyolite.Backend.App
44 | Rhyolite.Backend.WebSocket
45 |
46 | other-extensions: TemplateHaskell
47 | ghc-options:
48 | -Wall -fno-warn-unused-do-bind -fwarn-tabs -funbox-strict-fields
49 | -O2 -fprof-auto-calls
50 |
--------------------------------------------------------------------------------
/beam/db/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/beam/db/rhyolite-beam-db.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: rhyolite-beam-db
3 | version: 0.1.0.0
4 | synopsis: Beam database functions.
5 | homepage: https://github.com/obsidiansystems/rhyolite
6 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
7 | license: BSD-3-Clause
8 | license-file: LICENSE
9 | author: Obsidian Systems LLC
10 | maintainer: maintainer@obsidian.systems
11 | copyright: 2021 Obsidian Systems LLC
12 | category: Web
13 |
14 | library
15 | exposed-modules:
16 | Rhyolite.DB.Beam
17 | Rhyolite.DB.Beam.Types
18 |
19 | build-depends:
20 | base
21 | , lens
22 | , rhyolite-beam-orphans
23 | , beam-core
24 | , beam-postgres
25 | , postgresql-simple
26 | , time
27 |
28 | hs-source-dirs: src
29 | default-language: Haskell2010
30 | ghc-options: -Wall
31 |
--------------------------------------------------------------------------------
/beam/db/src/Rhyolite/DB/Beam.hs:
--------------------------------------------------------------------------------
1 | {-# Language FlexibleContexts #-}
2 | {-# Language OverloadedStrings #-}
3 | {-# Language TypeFamilies #-}
4 | {-|
5 | Description : Utility functions for using Beam with Postgres Transactions.
6 | -}
7 | module Rhyolite.DB.Beam where
8 |
9 | import Data.Time
10 | import Database.Beam
11 | import Database.Beam.Postgres
12 | import Database.Beam.Postgres.Syntax
13 | import Database.PostgreSQL.Simple.Transaction
14 |
15 | import Rhyolite.DB.Beam.Orphans ()
16 |
17 | -- | Run beam SQL statements inside a Postgres Serializable Transaction
18 | withTransactionSerializableRunBeamPostgres :: (MonadIO m) => Connection -> Pg a -> m a
19 | withTransactionSerializableRunBeamPostgres dbConn = liftIO . withTransactionSerializable dbConn . runBeamPostgres dbConn
20 |
21 | -- | Postgres @current_timestamp()@ function. Returns the server's timestamp
22 | current_timestamp_ :: QExpr Postgres s UTCTime
23 | -- Note: Previously we used the SQL expression @current_timestamp at time zone 'UTC'@
24 | -- here instead of @current_timestamp@.
25 | -- This caused a bug because this expression returns the current UTC time
26 | -- but without any time zone information; ie. the value would have the type
27 | -- @TIMESTAMP WITHOUT TIME ZONE@. When a value of this type is inserted
28 | -- into a column of type @TIMESTAMP WITH TIME ZONE@ it is cast into a value
29 | -- of the latter type by assuming the time zone is whatever the Postgres
30 | -- server is configured to use. This caused wrong timestamps to be inserted
31 | -- for all Postgres server instances whose time zone was not configured to
32 | -- be UTC.
33 | -- The type of the expression @current_timestamp@ is @TIMESTAMP WITH TIME ZONE@,
34 | -- which Postgres internally converts into a UTC timestamp which it stores.
35 | -- When this is retrieved from the database, Postgres read the stored UTC
36 | -- timestamp and returns the timestamp string using whatever time zone the
37 | -- server is configured to use. This string is deserialized into a 'UTCTime'
38 | -- (by 'postgresql-simple') by looking at the returned time zone offset and
39 | -- adjusting to UTC.
40 | current_timestamp_ = QExpr (\_ -> PgExpressionSyntax (emit "current_timestamp"))
41 |
--------------------------------------------------------------------------------
/beam/db/src/Rhyolite/DB/Beam/Types.hs:
--------------------------------------------------------------------------------
1 | {-# language DeriveGeneric #-}
2 | {-# language FlexibleInstances #-}
3 | {-# language MultiParamTypeClasses #-}
4 | {-# language PolyKinds #-}
5 | {-# language RankNTypes #-}
6 | {-# language TemplateHaskell #-}
7 | {-# language TypeFamilies #-}
8 | {-|
9 | Description:
10 | Types and helpers for Beam that can be used in schemas and database interactions.
11 | -}
12 | module Rhyolite.DB.Beam.Types where
13 |
14 | import Control.Lens
15 | import Data.Proxy
16 | import Database.Beam
17 | import Rhyolite.DB.Beam.Orphans ()
18 |
19 | -- | Like "Columnar", but a newtype instead of a type family, and the arguments
20 | -- are in a more convenient order.
21 | newtype WrapColumnar a f = WrapColumnar { unWrapColumnar :: Columnar f a }
22 | deriving (Generic)
23 |
24 | instance Beamable (WrapColumnar a)
25 |
26 | makeWrapped ''WrapColumnar
27 |
28 | -- | Used to decorate a beam thing like PrimaryKey with Nullable
29 | newtype WrapNullable k f = WrapNullable { unWrapNullable :: k (Nullable f) }
30 | deriving (Generic)
31 |
32 | makeWrapped ''WrapNullable
33 |
34 | -- | Useful in 'Rhyolite.Task.Beam.Task' for "no data" in payload or result.
35 | -- Every table has a subtable of type 'DummyTable'.
36 | type DummyTable = (Proxy :: k -> *)
37 |
38 | -- | Nicer name for 'Proxy' that explains what it's useful for in certain
39 | -- contexts: A phantom standing in for a null part of a schema.
40 | dummyTable :: forall k (x :: k). Proxy x
41 | dummyTable = Proxy
42 |
43 | -- | Every Beam table has a subtable of 'DummyTable'.
44 | dummyTableLens :: forall k x. Lens' (k x) (DummyTable x)
45 | dummyTableLens = lens
46 | (\_ -> Proxy)
47 | (\t _ -> t)
48 |
--------------------------------------------------------------------------------
/beam/orphans/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/beam/orphans/rhyolite-beam-orphans.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: rhyolite-beam-orphans
3 | version: 0.1.0.0
4 | synopsis: Missing instances that have not yet been upstreamed to beam
5 | homepage: https://github.com/obsidiansystems/rhyolite
6 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
7 | license: BSD-3-Clause
8 | license-file: LICENSE
9 | author: Obsidian Systems LLC
10 | maintainer: maintainer@obsidian.systems
11 | copyright: 2021 Obsidian Systems LLC
12 | category: Web
13 |
14 | library
15 | exposed-modules:
16 | Rhyolite.DB.Beam.Orphans
17 |
18 | build-depends:
19 | base
20 | , beam-core
21 |
22 | hs-source-dirs: src
23 | default-language: Haskell2010
24 | ghc-options: -Wall
25 |
--------------------------------------------------------------------------------
/beam/orphans/src/Rhyolite/DB/Beam/Orphans.hs:
--------------------------------------------------------------------------------
1 | {-# OPTIONS_GHC -fno-warn-orphans #-}
2 | {-# language TypeOperators #-}
3 | {-|
4 | Description:
5 | Types and helpers for Beam that can be used in schemas and database interactions.
6 | -}
7 | module Rhyolite.DB.Beam.Orphans where
8 |
9 | import Data.Functor.Product
10 | import Data.Proxy
11 | import Database.Beam
12 | import GHC.Generics
13 |
14 | instance Beamable Proxy
15 | instance (Beamable f, Beamable g) => Beamable (f :*: g)
16 | instance (Beamable f, Beamable g) => Beamable (Product f g)
17 |
--------------------------------------------------------------------------------
/beam/task/backend/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/beam/task/backend/rhyolite-beam-task-worker-backend.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: rhyolite-beam-task-worker-backend
3 | version: 0.1.0.0
4 | synopsis: Functions for beam based task workers.
5 | homepage: https://github.com/obsidiansystems/rhyolite
6 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
7 | license: BSD-3-Clause
8 | license-file: LICENSE
9 | author: Obsidian Systems LLC
10 | maintainer: maintainer@obsidian.systems
11 | copyright: 2021 Obsidian Systems LLC
12 | category: Web
13 |
14 | library
15 | exposed-modules:
16 | Rhyolite.Task.Beam.Worker
17 |
18 | build-depends:
19 | base
20 | , async
21 | , beam-core
22 | , beam-postgres
23 | , lens
24 | , lifted-base
25 | , monad-logger
26 | , monad-logger-extras
27 | , monad-control
28 | , mtl
29 | , psql-serializable
30 | , rhyolite-beam-db
31 | , rhyolite-beam-task-worker-types
32 | , time
33 | , unbounded-delays
34 |
35 | hs-source-dirs: src
36 | default-language: Haskell2010
37 | ghc-options: -Wall
38 |
39 | test-suite test
40 | other-modules:
41 | Types
42 | , Utils
43 |
44 | type: exitcode-stdio-1.0
45 | main-is: Test.hs
46 | hs-source-dirs: test
47 | default-language: Haskell2010
48 | build-depends:
49 | rhyolite-beam-task-worker-backend
50 | , rhyolite-beam-task-worker-types
51 | , base
52 | , beam-automigrate
53 | , beam-core
54 | , beam-postgres
55 | , containers
56 | , filepath
57 | , gargoyle-postgresql-connect
58 | , hspec
59 | , lens
60 | , monad-logger
61 | , postgresql-simple
62 | , psql-serializable
63 | , resource-pool
64 | , text
65 | , unix
66 | ghc-options: -threaded
67 |
--------------------------------------------------------------------------------
/beam/task/backend/src/Rhyolite/Task/Beam/Worker.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE FlexibleContexts #-}
2 | {-# Language RankNTypes #-}
3 | {-# Language ScopedTypeVariables #-}
4 | {-# Language TypeFamilies #-}
5 | {-|
6 | Description : Utility functions for creating worker threads, and Beam specific task workers for running SQL.
7 | -}
8 | module Rhyolite.Task.Beam.Worker where
9 |
10 | import Control.Lens (view)
11 | import Control.Concurrent
12 | import Control.Concurrent.Async
13 | import Control.Concurrent.Thread.Delay
14 | import Control.Exception.Lifted (bracket)
15 | import Control.Monad (forM)
16 | import Control.Monad.Cont
17 | import Control.Monad.Trans.Control
18 | import Data.Time
19 |
20 | import Database.Beam
21 | import Database.Beam.Backend.SQL
22 | import Database.Beam.Postgres
23 | import Database.Beam.Postgres.Syntax
24 | import Database.Beam.Query.Internal (QNested)
25 | import Database.Beam.Schema.Tables
26 |
27 | import Rhyolite.DB.Beam
28 | import Rhyolite.Task.Beam
29 | import Rhyolite.DB.Beam.Types (WrapColumnar(..))
30 |
31 | -- | Takes a worker continuation and handles checking out and checking in a task
32 | -- that is stored in a database table. The 'Rhyolite.Task.Beam.Task' type tells
33 | -- it how to find eligible tasks, how to extract a useful payload from the row,
34 | -- and how to put results back into the row while the continuation does the real
35 | -- work.
36 | --
37 | -- The worker continuation is divided into 3 phases:
38 | --
39 | -- 1. A checkout action that is transaction safe (it may retry).
40 | -- 2. A work action that is not transaction safe (it will not retry).
41 | -- 3. A commit action that is transaction safe (it may retry).
42 | --
43 | -- The continuation can perform its own queries in the checkout transaction but
44 | -- it is ideal to spend as little time as possible in this phase for the sake
45 | -- of throughput.
46 | --
47 | -- This function differs from $taskWorker$ in that there are no guardrails to
48 | -- prevent accidental (or intentional) task loops. unless the result changes
49 | -- the task to no longer match the filter, the task will run again.
50 | taskWorkerWithoutHasRun
51 | :: forall m be db table f payload checkout result.
52 | ( MonadIO m, Database be db, Beamable table, Table table
53 | , Beamable payload, Beamable result
54 | , FromBackendRow be (PrimaryKey table Identity)
55 | , FromBackendRow be (payload Identity)
56 | , FieldsFulfillConstraint (HasSqlEqualityCheck be) (PrimaryKey table)
57 | , FieldsFulfillConstraint (HasSqlValueSyntax PgValueSyntax) (PrimaryKey table)
58 | , FieldsFulfillConstraint (HasSqlValueSyntax PgValueSyntax) result
59 | , HasSqlValueSyntax PgValueSyntax checkout
60 | , be ~ Postgres, f ~ QExpr Postgres (QNested QBaseScope)
61 | )
62 | => Connection
63 | -> DatabaseEntity be db (TableEntity table)
64 | -- ^ The table whose rows represent tasks to be run
65 | -> TaskWithoutHasRun be table payload checkout result
66 | -- ^ Description of how task data is embedded within the table
67 | -> (PrimaryKey table Identity -> payload Identity -> Pg (m (Pg (result Identity))))
68 | -- ^ Worker continuation
69 | -> checkout
70 | -- ^ Identifier for the worker checking out the task
71 | -> m Bool
72 | taskWorkerWithoutHasRun dbConn table schema k checkoutId = do
73 | -- Checkout Phase
74 | mCheckout <-
75 | -- Do the following inside a transaction:
76 | -- 1. Get the first task that is not currently checked out by any worker
77 | -- 2. Update this task to reflect that it has been checked out by current worker
78 | -- 3. Run the specified checkout task which returns the work continuation
79 | withTransactionSerializableRunBeamPostgres dbConn $ do
80 | primaryKeyAndInput <- runSelectReturningOne $ select $ limit_ 1 $ do
81 | task <- all_ table
82 |
83 | -- Both task fields should be empty for an unclaimed task
84 | -- Also apply any other filters that may have been passed, using ready
85 | guard_ $ isNothing_ (_taskWithoutHasRun_checkedOutBy schema task)
86 | &&. (_taskWithoutHasRun_filter schema task)
87 |
88 | -- Return the primary key (task id) along with a custom field that the user asked for.
89 | pure (primaryKey task, _taskWithoutHasRun_payload schema task)
90 | -- In case we did not find any rows, no update SQL will be run
91 | -- The row lock that we acquired above will be reset when the transaction ends.
92 | forM primaryKeyAndInput $ \(taskId, input) -> do
93 | -- Mark the retrieved task as checked out, by the current worker
94 | runUpdate $
95 | update table
96 | (\task -> _taskWithoutHasRun_checkedOutBy schema task <-. val_ (Just checkoutId))
97 | (\task -> primaryKey task ==. val_ taskId)
98 |
99 | (,) taskId <$> k taskId input
100 | case mCheckout of
101 | Nothing -> pure False
102 | Just (taskId, workAction) -> do
103 | -- Work phase
104 | commitAction <- workAction
105 |
106 | -- Commit phase
107 | withTransactionSerializableRunBeamPostgres dbConn $ do
108 | -- Get the result value from the serializable
109 | b <- commitAction
110 |
111 | -- Update the task's result field, set checked out field to null
112 | runUpdate $ update table
113 | (\task -> mconcat
114 | [ _taskWithoutHasRun_result schema task <-. val_ b
115 | , _taskWithoutHasRun_checkedOutBy schema task <-. val_ Nothing
116 | ])
117 | (\task -> primaryKey task ==. val_ taskId)
118 |
119 | pure True
120 |
121 |
122 | -- | Takes a worker continuation and handles checking out and checking in a task
123 | -- that is stored in a database table. The 'Rhyolite.Task.Beam.Task' type tells
124 | -- it how to find eligible tasks, how to extract a useful payload from the row,
125 | -- and how to put results back into the row while the continuation does the real
126 | -- work.
127 | --
128 | -- The worker continuation is divided into 3 phases:
129 | --
130 | -- 1. A checkout action that is transaction safe (it may retry).
131 | -- 2. A work action that is not transaction safe (it will not retry).
132 | -- 3. A commit action that is transaction safe (it may retry).
133 | --
134 | -- The continuation can perform its own queries in the checkout transaction but
135 | -- it is ideal to spend as little time as possible in this phase for the sake
136 | -- of throughput.
137 | --
138 | -- This function differs from $taskWorkerWithoutHasRun$ in that it enforces a
139 | -- task stop via $_task_hasRun$; which must be False to be selected for
140 | -- execution, and is unconditionally set to True after the task is completed;
141 | taskWorker
142 | :: forall m be db table f payload checkout result.
143 | ( MonadIO m, Database be db, Beamable table, Table table
144 | , Beamable payload, Beamable result
145 | , FromBackendRow be (PrimaryKey table Identity)
146 | , FromBackendRow be (payload Identity)
147 | , FieldsFulfillConstraint (HasSqlEqualityCheck be) (PrimaryKey table)
148 | , FieldsFulfillConstraint (HasSqlValueSyntax PgValueSyntax) (PrimaryKey table)
149 | , FieldsFulfillConstraint (HasSqlValueSyntax PgValueSyntax) result
150 | , HasSqlValueSyntax PgValueSyntax checkout
151 | , be ~ Postgres, f ~ QExpr Postgres (QNested QBaseScope)
152 | )
153 | => Connection
154 | -> DatabaseEntity be db (TableEntity table)
155 | -- ^ The table whose rows represent tasks to be run
156 | -> Task be table payload checkout result
157 | -- ^ Description of how task data is embedded within the table
158 | -> (PrimaryKey table Identity -> payload Identity -> Pg (m (Pg (result Identity))))
159 | -- ^ Worker continuation
160 | -> checkout
161 | -- ^ Identifier for the worker checking out the task
162 | -> m Bool
163 | taskWorker dbConn table schema k = taskWorkerWithoutHasRun dbConn table schema1 $ \tId p -> do
164 | k' <- k tId p
165 | pure $ do
166 | k'' <- k'
167 | pure $ do
168 | res <- k''
169 | pure (res :*: WrapColumnar True)
170 | where
171 | schema1 = TaskWithoutHasRun
172 | { _taskWithoutHasRun_filter = \tbl -> not_ (view (_task_hasRun schema) tbl) &&. _task_filter schema tbl
173 | , _taskWithoutHasRun_payload = _task_payload schema
174 | , _taskWithoutHasRun_result = \tbl -> view (_task_result schema) tbl :*: WrapColumnar (view (_task_hasRun schema) tbl)
175 | , _taskWithoutHasRun_checkedOutBy = view (_task_checkedOutBy schema)
176 | }
177 |
178 |
179 | -- | Run a worker thread
180 | -- The worker will wake up whenever the timer expires or the wakeup action is called
181 | -- Once woken up, the worker will be run repeatedly until it reports that it was not able to find any work to do; then it will start sleeping for the given duration.
182 | -- If the wakeup action is called while the worker is running, the worker will run again as soon as it finishes, even if it returns False. This is necessary because otherwise, since checking for work isn't generally atomic, there would be a race condition: worker starts (e.g. enters looking-for-work transaction), work is created, wakeup called, worker finishes with no work found, sleep.
183 | withWorker
184 | :: (MonadIO m, MonadBaseControl IO m)
185 | => NominalDiffTime
186 | -- ^ Sleep interval
187 | -> IO Bool
188 | -- ^ The worker action, which reports whether it found work to do or not.
189 | -> (IO () -> m a)
190 | -- ^ Program that is given the option to prompt the worker thread to look for work.
191 | -> m a
192 | withWorker d work child = do
193 | initialStartVar <- liftIO $ newMVar ()
194 | startVarVar <- liftIO $ newMVar initialStartVar
195 | let wakeup = void $ withMVar startVarVar $ \startVar -> tryPutMVar startVar ()
196 | sleep startVar = void $ forkIO $ do
197 | delay $ ceiling $ d * 1000000
198 | putMVar startVar () -- Do this blockingly so the thread can theoretically be GCed if it becomes useless
199 | go startVar = do
200 | nextStartVar <- newEmptyMVar
201 | void $ takeMVar startVar
202 | modifyMVar_ startVarVar $ \_ -> pure nextStartVar
203 | didWork <- withAsync work waitCatch
204 | case didWork of
205 | Left e -> do
206 | putStrLn $ "withWorker: error in worker: " <> show e --TODO: Use MonadLogger
207 | sleep nextStartVar
208 | Right True -> void $ tryPutMVar nextStartVar ()
209 | Right False -> sleep nextStartVar
210 | go nextStartVar
211 | bracket (liftIO $ async $ go initialStartVar) (liftIO . cancel) $ \_ -> child wakeup
212 |
213 | -- | Run multiple workers in parallel on the same task
214 | withConcurrentWorkers
215 | :: forall m r a. (MonadIO m, MonadBaseControl IO m)
216 | => Int
217 | -- ^ Number of workers
218 | -> NominalDiffTime
219 | -- ^ Sleep interval for each worker
220 | -> (a -> IO Bool)
221 | -- ^ Parameterized worker action
222 | -> (Int -> a)
223 | -- ^ How to derive the worker's action parameter from its index
224 | -> (IO () -> m r)
225 | -- ^ Program that is given the option to prompt all the worker threads to look for work.
226 | -> m r
227 | withConcurrentWorkers n0 d work argFn = runContT $ go n0
228 | where
229 | go :: Int -> ContT r m (IO ())
230 | go n = do
231 | wakeup <- ContT $ withWorker d (work $ argFn n)
232 | wakeupRest <- if n > 1
233 | then go (n-1)
234 | else return $ return ()
235 | return (wakeup *> wakeupRest)
236 |
--------------------------------------------------------------------------------
/beam/task/backend/test/Types.hs:
--------------------------------------------------------------------------------
1 | {-# Language DataKinds #-}
2 | {-# Language DeriveAnyClass #-}
3 | {-# Language DeriveGeneric #-}
4 | {-# Language FlexibleInstances #-}
5 | {-# LANGUAGE MultiParamTypeClasses #-}
6 | {-# LANGUAGE OverloadedStrings #-}
7 | {-# Language StandaloneDeriving #-}
8 | {-# Language TemplateHaskell #-}
9 | {-# LANGUAGE TypeApplications #-}
10 | {-# Language TypeFamilies #-}
11 |
12 | module Types where
13 |
14 | import Control.Exception
15 | import Control.Lens
16 | import Control.Monad.Logger
17 | import Data.Int (Int64)
18 | import Data.Proxy
19 | import Data.String (fromString)
20 | import Data.Text (Text)
21 | import Database.Beam
22 | import qualified Database.Beam.AutoMigrate as BA
23 | import Database.Beam.Postgres
24 |
25 | import Rhyolite.Task.Beam
26 |
27 | data TestTaskT f = TestTaskT
28 | { _testTaskT_id :: Columnar f Int64
29 | , _testTaskT_checkedOutBy :: Columnar f (Maybe Text)
30 | , _testTaskT_payload :: Columnar f Int64
31 | , _testTaskT_result :: Columnar f (Maybe Bool)
32 | , _testTaskT_finished :: Columnar f Bool
33 | } deriving (Generic)
34 |
35 | makeLenses ''TestTaskT
36 |
37 | type TestTask = TestTaskT Identity
38 | type TestTaskId = PrimaryKey TestTaskT Identity
39 |
40 | deriving instance Eq TestTask
41 |
42 | instance Beamable TestTaskT
43 | instance Table TestTaskT where
44 | newtype PrimaryKey TestTaskT f = TestTaskId { unTestTaskId :: Columnar f Int64 }
45 | deriving (Generic)
46 | primaryKey = TestTaskId . _testTaskT_id
47 |
48 | instance Beamable (PrimaryKey TestTaskT)
49 |
50 | newtype WrappedColumnar a f = WrappedColumnar { unWrappedColumnar :: Columnar f a }
51 | deriving (Generic)
52 |
53 | instance Beamable (WrappedColumnar a)
54 |
55 | testTask :: Task Postgres TestTaskT (WrappedColumnar Int64) Text (WrappedColumnar (Maybe Bool))
56 | testTask = Task
57 | { _task_filter = \_ -> val_ True
58 | , _task_payload = WrappedColumnar . _testTaskT_payload
59 | , _task_checkedOutBy = testTaskT_checkedOutBy
60 | , _task_hasRun = testTaskT_finished
61 | , _task_result = lens
62 | (\t -> WrappedColumnar (_testTaskT_result t))
63 | (\t (WrappedColumnar s) -> t
64 | { _testTaskT_result = s
65 | }
66 | )
67 | }
68 |
69 | createTask :: Int64 -> TestTask
70 | createTask i = TestTaskT
71 | { _testTaskT_id = i
72 | , _testTaskT_checkedOutBy = Nothing
73 | , _testTaskT_payload = i
74 | , _testTaskT_result = Nothing
75 | , _testTaskT_finished = False
76 | }
77 |
78 | newtype TestTasksDb f = TestTasksDb
79 | { _testTasksDb_tasks :: f (TableEntity TestTaskT)
80 | } deriving (Generic)
81 |
82 | instance Database be TestTasksDb
83 |
84 | tasksDb :: DatabaseSettings be TestTasksDb
85 | tasksDb = defaultDbSettings
86 |
87 | tasksDbPostgres :: BA.AnnotatedDatabaseSettings Postgres TestTasksDb
88 | tasksDbPostgres = BA.defaultAnnotatedDbSettings tasksDb
89 |
90 | taskSchema :: BA.Schema
91 | taskSchema = BA.fromAnnotatedDbSettings tasksDbPostgres (Proxy @'[])
92 |
93 | data TestException = TestException
94 | deriving (Eq, Show, Typeable)
95 |
96 | instance Exception TestException
97 |
--------------------------------------------------------------------------------
/beam/task/backend/test/Utils.hs:
--------------------------------------------------------------------------------
1 | {-# Language FlexibleContexts #-}
2 | module Utils where
3 |
4 | import Control.Concurrent (forkIO)
5 | import Control.Exception (throw)
6 | import Control.Monad (void, when)
7 | import Data.Int (Int64)
8 | import Data.IORef
9 | import Data.Text (Text)
10 | import Database.Beam
11 | import Database.Beam.Backend.SQL.SQL92
12 | import Database.Beam.Postgres
13 | import Database.Beam.Postgres.Syntax
14 | import Database.PostgreSQL.Simple
15 | import Database.PostgreSQL.Serializable
16 | import Rhyolite.Task.Beam.Worker
17 | import Types
18 |
19 | type Work = Int64 -> Pg (IO (Pg (WrappedColumnar (Maybe Bool) Identity)))
20 |
21 | insertTestTasks :: Connection -> [TestTask] -> IO ()
22 | insertTestTasks c = runBeamPostgres c . runInsert . insert (_testTasksDb_tasks tasksDb) . insertValues
23 |
24 | createTaskWorker :: Connection -> Work -> Text -> IO Bool
25 | createTaskWorker conn work wId = taskWorker
26 | conn
27 | (_testTasksDb_tasks tasksDb)
28 | testTask
29 | (\_ -> work . unWrappedColumnar)
30 | wId
31 |
32 | allTestTasks :: Connection -> IO [TestTask]
33 | allTestTasks c =
34 | runBeamPostgres c $ runSelectReturningList $
35 | select $ all_ (_testTasksDb_tasks tasksDb)
36 |
37 | justOneTestTask :: Connection -> IO (Maybe TestTask)
38 | justOneTestTask c =
39 | runBeamPostgres c $ runSelectReturningOne $
40 | select $ all_ (_testTasksDb_tasks tasksDb)
41 |
42 | spawnTaskWorker :: Work -> Connection -> Text -> IO ()
43 | spawnTaskWorker work conn = void . forkIO . void . createTaskWorker conn work
44 |
45 | toggleBoolIORef :: IORef Bool -> Bool -> Work
46 | toggleBoolIORef boolRef flag = const $ pure $ do
47 | when flag $ throw TestException
48 | atomicModifyIORef boolRef (\b -> (not b, ()))
49 | pure $ pure $ WrappedColumnar (Just True)
50 |
--------------------------------------------------------------------------------
/beam/task/types/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/beam/task/types/rhyolite-beam-task-worker-types.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: rhyolite-beam-task-worker-types
3 | version: 0.1.0.0
4 | synopsis: Types for beam based task workers.
5 | homepage: https://github.com/obsidiansystems/rhyolite
6 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
7 | license: BSD-3-Clause
8 | license-file: LICENSE
9 | author: Obsidian Systems LLC
10 | maintainer: maintainer@obsidian.systems
11 | copyright: 2021 Obsidian Systems LLC
12 | category: Web
13 |
14 | library
15 | exposed-modules:
16 | Rhyolite.Task.Beam
17 |
18 | build-depends:
19 | base
20 | , beam-core
21 | , lens
22 |
23 | hs-source-dirs: src
24 | default-language: Haskell2010
25 | ghc-options: -Wall
26 |
--------------------------------------------------------------------------------
/beam/task/types/src/Rhyolite/Task/Beam.hs:
--------------------------------------------------------------------------------
1 | {-# Language DeriveAnyClass #-}
2 | {-# Language DeriveGeneric #-}
3 | {-# Language FlexibleInstances #-}
4 | {-# Language FunctionalDependencies #-}
5 | {-# Language KindSignatures #-}
6 | {-# Language RankNTypes #-}
7 | {-# Language StandaloneDeriving #-}
8 | {-# Language TemplateHaskell #-}
9 | {-|
10 | Description : Models the interface to a work queue that is stored in a database table.
11 |
12 | The 'Task' type in this module describes how to interact with a 'Table' that tracks tasks that can be checked out and processed by workers in a distributed but serializable fashion. In this model tasks are not locked by workers but are instead atomically checked out for processing and then later atomically checked in when processing is done.
13 | -}
14 | module Rhyolite.Task.Beam where
15 |
16 | import Control.Lens
17 |
18 | import Database.Beam
19 |
20 | -- | The Task type describes how to use a database table to check out tasks
21 | -- and record back the results after processing them.
22 | --
23 | -- One can use 'Rhyolite.Task.Beam.Worker.taskWorker' to process a job
24 | -- given a 'Task' representing the job queue's interface.
25 | data Task be table payload checkout result = Task
26 | { _task_filter :: forall s. table (QExpr be s) -> QExpr be s Bool
27 | -- ^ A user-supplied predicate for choosing suitable tasks. This
28 | -- is combined with the logic that handles checkout and checkin
29 | -- in 'Rhyolite.Task.Beam.Worker.taskWorker'.
30 | , _task_payload :: forall s. table (QExpr be s) -> payload (QExpr be s)
31 | -- ^ How to extract the payload from the row
32 | , _task_checkedOutBy :: forall x. Lens' (table x) (C x (Maybe checkout))
33 | -- ^ How the field which records a checkout is embedded within a row;
34 | -- a lens allows both reading and writing.
35 | , _task_hasRun :: forall x. Lens' (table x) (C x Bool)
36 | -- ^ Which field indicates that the task result has been checked in.
37 | , _task_result :: forall x. Lens' (table x) (result x)
38 | -- ^ How the result data is embedded within a row.
39 | -- Note that it has to be a 'Beamable' type in its own right, so if the
40 | -- result is a mere 'Columnar' type it should be wrapped in a newtype.
41 | }
42 |
43 | -- | The TaskWithoutHasRun type describes how to use a database table to check out tasks
44 | -- and record back the results after processing them.
45 | --
46 | -- One can use 'Rhyolite.Task.Beam.Worker.taskWorkerWithoutHasRun' to process a job
47 | -- given a 'TaskWithoutHasRun' representing the job queue's interface.
48 | data TaskWithoutHasRun be table payload checkout result = TaskWithoutHasRun
49 | { _taskWithoutHasRun_filter :: forall s. table (QExpr be s) -> QExpr be s Bool
50 | -- ^ A user-supplied predicate for choosing suitable tasks. This
51 | -- is combined with the logic that handles checkout and checkin
52 | -- in 'Rhyolite.Task.Beam.Worker.taskWorker'.
53 | , _taskWithoutHasRun_payload :: forall s. table (QExpr be s) -> payload (QExpr be s)
54 | -- ^ How to extract the payload from the row
55 | , _taskWithoutHasRun_checkedOutBy :: forall x. table x -> C x (Maybe checkout)
56 | -- ^ How the field which records a checkout is embedded within a row;
57 | -- a lens allows both reading and writing.
58 | , _taskWithoutHasRun_result :: forall s. table (QField s) -> result (QField s)
59 | -- ^ How the result data is embedded within a row.
60 | -- Note that it has to be a 'Beamable' type in its own right, so if the
61 | -- result is a mere 'Columnar' type it should be wrapped in a newtype.
62 | }
63 |
--------------------------------------------------------------------------------
/cabal.project:
--------------------------------------------------------------------------------
1 | packages:
2 | account/backend/
3 | account/types/
4 | backend/
5 | beam/db/
6 | beam/task/backend/
7 | beam/task/types/
8 | common/
9 | semimap/
10 | email/
11 | email/mime-mail-orphans/
12 | frontend/
13 | notify-listen/notify-listen-beam/
14 | notify-listen/notify-listen/
15 | psql-extras/psql-serializable/
16 | psql-extras/psql-simple-beam/
17 | psql-extras/psql-simple-class/
18 | signed-data/signed-data/
19 | signed-data/signed-data-clientsession/
20 | test/
21 | widgets/
22 |
--------------------------------------------------------------------------------
/common/Data/Vessel/Void.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE KindSignatures #-}
2 | {-# LANGUAGE FlexibleInstances #-}
3 | {-# LANGUAGE TypeFamilies #-}
4 | {-# LANGUAGE DeriveGeneric #-}
5 |
6 | module Data.Vessel.Void where
7 |
8 | import Data.Aeson
9 | import GHC.Generics
10 | import Data.Functor.Const
11 | import Data.Functor.Identity
12 | import Data.Patch (Group(..))
13 | import Data.Vessel.Class
14 | import Reflex.Query.Class
15 |
16 | -- | completly empty View.
17 | data VoidV (v :: * -> *) = VoidV
18 | deriving (Eq, Ord, Show, Generic)
19 |
20 | instance FromJSON (VoidV a)
21 | instance ToJSON (VoidV a)
22 |
23 | instance Semigroup (VoidV x) where
24 | _ <> _ = VoidV
25 | instance Monoid (VoidV x) where
26 | mempty = VoidV
27 | instance Group (VoidV x) where
28 | negateG _ = VoidV
29 |
30 | instance View VoidV where
31 |
32 | instance Query (VoidV (Const x)) where
33 | type QueryResult (VoidV (Const x)) = VoidV Identity
34 | crop _ = id
35 |
36 | instance EmptyView VoidV where
37 | emptyV = VoidV
38 |
--------------------------------------------------------------------------------
/common/Rhyolite/Aeson/Orphans.hs:
--------------------------------------------------------------------------------
1 | {-# Language CPP #-}
2 | {-# Language OverloadedStrings #-}
3 | {-# Language StandaloneDeriving #-}
4 | {-# options_ghc -fno-warn-orphans #-}
5 | module Rhyolite.Aeson.Orphans where
6 |
7 | #if !MIN_VERSION_aeson(1,5,1) && MIN_VERSION_these(1,1,0)
8 | -- The aeson instances for These are now in aeson instead of these.
9 | -- reflex-platform hasn't updated to a newer aeson yet.
10 |
11 | import Data.Aeson ((.=), FromJSON(..), ToJSON(..))
12 | import qualified Data.Aeson as Aeson
13 | import qualified Data.Aeson.Encoding as Aeson (pair)
14 | import Data.Functor.These
15 | import qualified Data.HashMap.Strict as HM
16 | import Data.These
17 |
18 | -- | @since 0.7.1
19 | instance (ToJSON a, ToJSON b) => ToJSON (These a b) where
20 | toJSON (This a) = Aeson.object [ "This" .= a ]
21 | toJSON (That b) = Aeson.object [ "That" .= b ]
22 | toJSON (These a b) = Aeson.object [ "This" .= a, "That" .= b ]
23 |
24 | toEncoding (This a) = Aeson.pairs $ "This" .= a
25 | toEncoding (That b) = Aeson.pairs $ "That" .= b
26 | toEncoding (These a b) = Aeson.pairs $ "This" .= a <> "That" .= b
27 |
28 | -- | @since 0.7.1
29 | instance (FromJSON a, FromJSON b) => FromJSON (These a b) where
30 | parseJSON = Aeson.withObject "These a b" (p . HM.toList)
31 | where
32 | p [("This", a), ("That", b)] = These <$> parseJSON a <*> parseJSON b
33 | p [("That", b), ("This", a)] = These <$> parseJSON a <*> parseJSON b
34 | p [("This", a)] = This <$> parseJSON a
35 | p [("That", b)] = That <$> parseJSON b
36 | p _ = fail "Expected object with 'This' and 'That' keys only"
37 |
38 | -- | @since 0.7.2
39 | instance Aeson.ToJSON2 These where
40 | liftToJSON2 toa _ _tob _ (This a) = Aeson.object [ "This" .= toa a ]
41 | liftToJSON2 _toa _ tob _ (That b) = Aeson.object [ "That" .= tob b ]
42 | liftToJSON2 toa _ tob _ (These a b) = Aeson.object [ "This" .= toa a, "That" .= tob b ]
43 |
44 | liftToEncoding2 toa _ _tob _ (This a) = Aeson.pairs $ Aeson.pair "This" (toa a)
45 | liftToEncoding2 _toa _ tob _ (That b) = Aeson.pairs $ Aeson.pair "That" (tob b)
46 | liftToEncoding2 toa _ tob _ (These a b) = Aeson.pairs $ Aeson.pair "This" (toa a) <> Aeson.pair "That" (tob b)
47 |
48 | -- | @since 0.7.2
49 | instance ToJSON a => Aeson.ToJSON1 (These a) where
50 | liftToJSON _tob _ (This a) = Aeson.object [ "This" .= a ]
51 | liftToJSON tob _ (That b) = Aeson.object [ "That" .= tob b ]
52 | liftToJSON tob _ (These a b) = Aeson.object [ "This" .= a, "That" .= tob b ]
53 |
54 | liftToEncoding _tob _ (This a) = Aeson.pairs $ "This" .= a
55 | liftToEncoding tob _ (That b) = Aeson.pairs $ Aeson.pair "That" (tob b)
56 | liftToEncoding tob _ (These a b) = Aeson.pairs $ "This" .= a <> Aeson.pair "That" (tob b)
57 |
58 | -- | @since 0.7.2
59 | instance Aeson.FromJSON2 These where
60 | liftParseJSON2 pa _ pb _ = Aeson.withObject "These a b" (p . HM.toList)
61 | where
62 | p [("This", a), ("That", b)] = These <$> pa a <*> pb b
63 | p [("That", b), ("This", a)] = These <$> pa a <*> pb b
64 | p [("This", a)] = This <$> pa a
65 | p [("That", b)] = That <$> pb b
66 | p _ = fail "Expected object with 'This' and 'That' keys only"
67 |
68 | -- | @since 0.7.2
69 | instance FromJSON a => Aeson.FromJSON1 (These a) where
70 | liftParseJSON pb _ = Aeson.withObject "These a b" (p . HM.toList)
71 | where
72 | p [("This", a), ("That", b)] = These <$> parseJSON a <*> pb b
73 | p [("That", b), ("This", a)] = These <$> parseJSON a <*> pb b
74 | p [("This", a)] = This <$> parseJSON a
75 | p [("That", b)] = That <$> pb b
76 | p _ = fail "Expected object with 'This' and 'That' keys only"
77 |
78 | #else
79 | #endif
80 |
--------------------------------------------------------------------------------
/common/Rhyolite/Api.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description: Request/response API protocol
3 |
4 | This commonly used module details the mechanism that we use to bring
5 | information from the frontend to the backend of a typical Obelisk app. The
6 | important datatype here is 'ApiRequest' which is parametrized on three
7 | application-dependent datatypes: one, of kind @*@, for credentials, and two,
8 | of kind @k -> *@, respectively for the public and private part of the
9 | request. As an example, your app could have datatypes like:
10 |
11 | @
12 | data Credentials where
13 | ...
14 |
15 | data PublicRequest a where
16 | PublicRequest_Login :: Email -> Password -> PublicRequest LoginResult
17 | ...
18 |
19 | data PrivateRequest a where
20 | PrivateRequest_BuyItem :: Item -> PrivateRequest ()
21 | PrivateRequest_CheckOut :: Item -> PrivateRequest CheckoutResult
22 | ...
23 | @
24 |
25 | and you'll work with an 'ApiRequest' of type:
26 |
27 | @
28 | ApiRequest Credentials PublicRequest PrivateRequest
29 | @
30 | -}
31 | {-# Language ConstraintKinds #-}
32 | {-# Language FlexibleContexts #-}
33 | {-# Language FlexibleInstances #-}
34 | {-# Language GADTs #-}
35 | {-# Language LambdaCase #-}
36 | {-# Language MultiParamTypeClasses #-}
37 | {-# Language PolyKinds #-}
38 | {-# Language TypeFamilies #-}
39 |
40 | module Rhyolite.Api where
41 |
42 | import Data.Aeson
43 | import Data.Constraint.Extras
44 | import Data.Constraint.Forall
45 | import Data.Some
46 |
47 | -- | JSON encoding and decoding constraints on requests
48 | type Request r = (ForallF ToJSON r, Has ToJSON r, FromJSON (Some r), Has FromJSON r)
49 |
50 | -- | In most applications, API requests are either authenticated or
51 | -- unauthenticated. A login request, for example, is usually unauthenticated,
52 | -- or "public."
53 | data ApiRequest :: * -> (k -> *) -> (k -> *) -> k -> * where
54 | ApiRequest_Public :: public a -> ApiRequest cred public private a
55 | ApiRequest_Private :: cred -> private a -> ApiRequest cred public private a
56 | deriving (Show)
57 |
58 | instance (Has c public, Has c private) => Has c (ApiRequest cred public private) where
59 | argDict = \case
60 | ApiRequest_Public x -> argDict x
61 | ApiRequest_Private _ x -> argDict x
62 |
63 | -- | Shorthand constructor for public requests
64 | public :: public t -> ApiRequest cred public private t
65 | public = ApiRequest_Public
66 |
67 | -- | Shorthand constructor for private requests
68 | private :: cred -> private t -> ApiRequest cred public private t
69 | private = ApiRequest_Private
70 |
71 | instance (ToJSON cred, ToJSON (public a), ToJSON (private a)) => ToJSON (ApiRequest cred public private a) where
72 | toJSON = \case
73 | ApiRequest_Public x -> toJSON ("public", toJSON x)
74 | ApiRequest_Private c x -> toJSON ("private", (toJSON x, toJSON c))
75 |
76 | instance (FromJSON cred, FromJSON (Some public), FromJSON (Some private)) => FromJSON (Some (ApiRequest cred public private)) where
77 | parseJSON v = do
78 | (tag,rest) <- parseJSON v
79 | case tag of
80 | "public" -> do
81 | Some x <- parseJSON rest
82 | return (Some (ApiRequest_Public x))
83 | "private" -> do
84 | (Some x, c) <- parseJSON rest
85 | return (Some (ApiRequest_Private c x))
86 | _ -> fail "Request appears neither public nor private"
87 |
--------------------------------------------------------------------------------
/common/Rhyolite/App.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description:
3 | 'Query' helpers
4 |
5 | Miscellaneous utilities related to the 'Query' datatype, and the definition of
6 | 'Single', a view for a single piece of data.
7 | -}
8 | {-# Language DeriveFoldable #-}
9 | {-# Language DeriveGeneric #-}
10 | {-# Language DeriveTraversable #-}
11 | {-# Language FlexibleContexts #-}
12 | {-# Language GeneralizedNewtypeDeriving #-}
13 | {-# Language PatternGuards #-}
14 | {-# Language PolyKinds #-}
15 | {-# Language ScopedTypeVariables #-}
16 | {-# Language StandaloneDeriving #-}
17 | {-# Language TypeApplications #-}
18 | {-# Language UndecidableInstances #-}
19 |
20 | {-# OPTIONS_GHC -fno-warn-orphans #-}
21 |
22 | module Rhyolite.App where
23 |
24 | import Data.Aeson (FromJSON, ToJSON)
25 | import Data.Align
26 | import qualified Data.AppendMap as MonoidalMap
27 | import Data.Constraint.Extras
28 | import qualified Data.Dependent.Map as DMap'
29 | import qualified Data.Dependent.Map.Monoidal as DMap
30 | import Data.Dependent.Sum
31 | import Data.Functor.Compose
32 | import Data.Functor.Const
33 | import Data.Functor.Identity
34 | import Data.GADT.Compare
35 | import Data.Map (Map)
36 | import Data.Map.Monoidal (MonoidalMap)
37 | import qualified Data.Map.Monoidal as MMap
38 | import Data.Proxy
39 | import Data.Semigroup (Semigroup)
40 | import qualified Data.Semigroup as Semigroup
41 | import Data.Semigroup (First(..))
42 | import Data.These
43 | import Data.These.Combinators
44 | import Data.Typeable (Typeable)
45 | import Data.Vessel
46 | import Data.Vessel.Void
47 | import Data.Vessel.Internal (VSum(..))
48 | import Data.Witherable (Filterable(..))
49 | import GHC.Generics (Generic)
50 | import Reflex.Query.Class
51 |
52 | -- | Set-subtraction operation for queries.
53 | class PositivePart q where
54 | positivePart :: q -> Maybe q
55 | -- ^ Filter a query to only those parts which are selected a positive
56 | -- amount.
57 |
58 | instance PositivePart SelectedCount where
59 | positivePart x
60 | | x > 0 = Just x
61 | | otherwise = Nothing
62 |
63 | instance PositivePart () where
64 | positivePart _ = Nothing
65 |
66 | instance PositivePart a => PositivePart (Identity a) where
67 | positivePart (Identity x) = Identity <$> positivePart x
68 |
69 | instance PositivePart x => PositivePart (Const x a) where
70 | positivePart (Const x) = Const <$> positivePart x
71 |
72 | instance PositivePart (Proxy a) where
73 | positivePart _ = Nothing
74 |
75 | instance (PositivePart a, PositivePart b) => PositivePart (These a b) where
76 | positivePart ab = align (positivePart =<< justHere ab) (positivePart =<< justThere ab)
77 |
78 | instance PositivePart (f (g x)) => PositivePart (Compose f g x) where
79 | positivePart (Compose xs) = Compose <$> positivePart xs
80 |
81 | instance Has' PositivePart f g => PositivePart (DSum f g) where
82 | positivePart (f :=> g) = (f :=>) <$> has' @PositivePart @g f (positivePart g)
83 |
84 | instance (GCompare f, Has' PositivePart f g) => PositivePart (DMap'.DMap f g) where
85 | positivePart xs
86 | | DMap'.null xs' = Nothing
87 | | otherwise = Just xs'
88 | where xs' = DMap'.mapMaybeWithKey (\f g -> has' @PositivePart @g f (positivePart g)) xs
89 |
90 | deriving instance (GCompare f, Has' PositivePart f g) => PositivePart (DMap.MonoidalDMap f g)
91 |
92 | instance HasV PositivePart f g => PositivePart (VSum f g) where
93 | positivePart (f :~> g) = (f :~>) <$> hasV @PositivePart @g f (positivePart g)
94 |
95 | deriving instance PositivePart (g (First (Maybe v))) => PositivePart (SingleV v g)
96 |
97 | deriving instance PositivePart (g v) => PositivePart (MapV k v g)
98 | deriving instance PositivePart (g v) => PositivePart (IdentityV v g)
99 | deriving instance PositivePart (g f) => PositivePart (FlipAp f g)
100 | deriving instance (GCompare f, Has' PositivePart f (FlipAp g)) => PositivePart (Vessel f g)
101 | deriving instance (Ord k, PositivePart (f g)) => PositivePart (SubVessel k f g)
102 | instance PositivePart (VoidV x) where positivePart = const Nothing
103 |
104 | instance PositivePart a => PositivePart [a] where positivePart = composePositivePart
105 | instance PositivePart a => PositivePart (Maybe a) where positivePart = composePositivePart
106 | instance PositivePart a => PositivePart (Map k a) where positivePart = composePositivePart
107 | deriving instance PositivePart a => PositivePart (MMap.MonoidalMap k a)
108 |
109 | -- | This can be used to implement an instance of PositivePart for
110 | -- Functor-style queries/views, in terms of the other instances already
111 | -- required for those.
112 | standardPositivePart :: (Eq (q a), Monoid (q a), Num a, Ord a, Filterable q) => q a -> Maybe (q a)
113 | standardPositivePart x =
114 | let u = mapMaybe (\n -> if n > 0 then Just n else Nothing) x
115 | in if u == mempty then Nothing else Just u
116 |
117 | -- | Map 'positivePart' over a structure. If the resulting structure is empty,
118 | -- 'Nothing' is returned
119 | composePositivePart :: (Foldable q, PositivePart a, Filterable q) => q a -> Maybe (q a)
120 | composePositivePart x =
121 | let u = mapMaybe positivePart x
122 | in if null u then Nothing else Just u
123 | {-# INLINE composePositivePart #-}
124 |
125 | -- | Converts between a query and a map of queries with at most one element
126 | -- (at the provided key)
127 | singletonQuery :: (Monoid (QueryResult q), Ord k) => k -> QueryMorphism q (MonoidalMap k q)
128 | singletonQuery k = QueryMorphism
129 | { _queryMorphism_mapQuery = MonoidalMap.singleton k
130 | , _queryMorphism_mapQueryResult = MonoidalMap.findWithDefault mempty k
131 | }
132 |
133 | {-# Deprecated cropView "Use 'crop' instead" #-}
134 | -- | See 'crop'
135 | cropView :: (Query q) => q -> QueryResult q -> QueryResult q
136 | cropView = crop
137 |
138 | -- | Specialized 'mapMaybe' for working with pairs where we only want to filter
139 | -- based on some property of the first element
140 | fmapMaybeFst :: Filterable f => (a -> Maybe b) -> f (a, c) -> f (b, c)
141 | fmapMaybeFst f = mapMaybe $ \(a, c) -> case f a of
142 | Nothing -> Nothing
143 | Just b -> Just (b, c)
144 |
145 | -- | A view for a single piece of data, supporting update and delete.
146 | newtype Single t a = Single { unSingle :: Maybe (Semigroup.First (Maybe t), a) }
147 | deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic, Typeable)
148 |
149 | instance Semigroup a => Semigroup (Single t a) where
150 | (<>) (Single Nothing) y = y
151 | (<>) x (Single Nothing) = x
152 | (<>) (Single (Just (t, a))) (Single (Just (_t, a'))) = Single $ Just (t, a Semigroup.<> a')
153 |
154 | instance Semigroup a => Monoid (Single t a) where
155 | mempty = Single Nothing
156 | mappend = (Semigroup.<>)
157 |
158 | instance Filterable (Single t) where
159 | mapMaybe f (Single (Just (t, x))) | Just y <- f x = Single (Just (t, y))
160 | mapMaybe _ _ = Single Nothing
161 |
162 | instance (FromJSON t, FromJSON a) => FromJSON (Single t a)
163 | instance (ToJSON t, ToJSON a) => ToJSON (Single t a)
164 |
165 | -- | Get the data out of a 'Single'
166 | getSingle :: Single t a -> Maybe t
167 | getSingle (Single (Just (Semigroup.First (Just t), _))) = Just t
168 | getSingle _ = Nothing
169 |
170 | -- | Wrap data in a 'Single'
171 | single :: Maybe t -> a -> Single t a
172 | single t a = Single $ Just (Semigroup.First t, a)
173 |
--------------------------------------------------------------------------------
/common/Rhyolite/Concurrent.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description:
3 | Respawning workers
4 |
5 | Create worker threads that are respawned in case of error.
6 | -}
7 |
8 | {-# Language ScopedTypeVariables #-}
9 |
10 | module Rhyolite.Concurrent where
11 |
12 | import Control.Concurrent (forkIO, killThread, threadDelay)
13 | import Control.Concurrent.Async (waitCatch, withAsync)
14 | import Control.Exception (SomeException, try)
15 | import Control.Monad ((<=<), forever, void, when)
16 | import Control.Monad.IO.Class (MonadIO, liftIO)
17 | import Data.Either (isLeft)
18 | import Data.Semigroup ((<>))
19 |
20 |
21 | -- | Perform a supervised operation with delays in between, on a separate thread. Return an IO action for killing the thread.
22 | worker :: (MonadIO m)
23 | => Int -- ^ Delay between operations, in microseconds
24 | -> IO a -- ^ Operation to perform
25 | -> m (IO ())
26 | worker = taggedWorker ""
27 |
28 | -- | Perform a tagged, supervised operation with delays in between, on a separate thread. Return an IO action for killing the thread.
29 | taggedWorker
30 | :: MonadIO m
31 | => String -- ^ Tag for this worker: displayed in error messages
32 | -> Int
33 | -> IO a
34 | -> m (IO ())
35 | taggedWorker tag delay x = return . killThread <=< liftIO . forkIO . supervise tag . void . forever $
36 | x >> threadDelay delay
37 |
38 | -- | Runs an action forever, restarting it if it dies.
39 | supervise :: Show a => String -> IO a -> IO ()
40 | supervise tag a = forever $ withAsync a $ \child -> do
41 | let msgPrefix = if null tag then "supervise: " else "supervise: " <> tag <> ": "
42 | result <- waitCatch child
43 | printResult :: Either SomeException () <- try $ putStrLn $ msgPrefix <> "child terminated with " <> show result <> "; restarting"
44 | threadDelay 1000000
45 | when (isLeft printResult) $ putStrLn $ msgPrefix <> "note: an exception was encountered when printing the previous result"
46 |
--------------------------------------------------------------------------------
/common/Rhyolite/Route.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description: Legacy application routes
3 |
4 | This module is still here for backward compatibility reasons. You should use
5 | "Obelisk.Route" instead.
6 | -}
7 | {-# Language CPP #-}
8 | {-# Language FlexibleInstances #-}
9 | {-# Language FunctionalDependencies #-}
10 | {-# Language GeneralizedNewtypeDeriving #-}
11 | {-# Language OverloadedStrings #-}
12 | {-# Language TypeFamilies #-}
13 | {-# Language UndecidableInstances #-}
14 |
15 | module Rhyolite.Route where
16 |
17 | import Control.Monad.Base
18 | import Control.Monad.Reader
19 | import Control.Monad.Trans.Control
20 | import Control.Monad.Trans.Except (ExceptT)
21 | import Control.Monad.Trans.Maybe (MaybeT)
22 | #if defined(VERSION_monad_logger)
23 | import Control.Monad.Logger
24 | #endif
25 | import Data.Aeson
26 | import qualified Data.ByteString as BS
27 | import qualified Data.ByteString.Lazy as LBS
28 | import Data.Default
29 | import qualified Data.Map as Map
30 | import Data.Map (Map)
31 | import qualified Data.Text as T
32 | import Data.Text.Encoding
33 | import Network.HTTP.Types.URI (parseQuery, renderQuery)
34 | import Network.URI
35 |
36 | -- | A class that can produce application-specific URLs
37 | class Monad m => MonadRoute r m | m -> r where
38 | routeToUrl :: r -> m URI
39 |
40 | -- | The protocol, hostname, and rest (e.g., port) of the app's configured route
41 | type RouteEnv = (String, String, String)
42 |
43 | -- | A transformer that carries around information about the route
44 | newtype RouteT r m a = RouteT { unRouteT :: ReaderT RouteEnv m a }
45 | deriving
46 | ( Functor, Applicative, Monad, MonadIO, MonadTrans
47 | #if defined(VERSION_monad_logger)
48 | , MonadLogger
49 | #endif
50 | )
51 |
52 | instance MonadTransControl (RouteT r) where
53 | type StT (RouteT r) a = a
54 | liftWith f = RouteT . ReaderT $ \r -> f $ \t -> runRouteT t r
55 | restoreT = RouteT . ReaderT . const
56 | {-# INLINABLE liftWith #-}
57 | {-# INLINABLE restoreT #-}
58 |
59 | instance MonadBase b m => MonadBase b (RouteT r m) where
60 | liftBase = lift . liftBase
61 |
62 | instance (MonadBaseControl b m) => MonadBaseControl b (RouteT r m) where
63 | type StM (RouteT r m) a = ComposeSt (RouteT r) m a
64 | liftBaseWith = defaultLiftBaseWith
65 | restoreM = defaultRestoreM
66 | {-# INLINABLE liftBaseWith #-}
67 | {-# INLINABLE restoreM #-}
68 |
69 | -- | Runs a 'RouteT' action
70 | runRouteT :: RouteT r m a -> RouteEnv -> m a
71 | runRouteT = runReaderT . unRouteT
72 |
73 | instance (Monad m, ToJSON r, Default r, Eq r) => MonadRoute r (RouteT r m) where
74 | routeToUrl r = do
75 | routeEnv <- RouteT ask
76 | return $ routeToUrlDefault routeEnv r
77 |
78 | -- | Constructs a route using a 'RouteEnv'
79 | routeToUrlDefault :: (ToJSON r, Default r, Eq r)
80 | => RouteEnv
81 | -> r
82 | -> URI
83 | routeToUrlDefault (baseProto, baseHost, basePort) r =
84 | let base = URI baseProto (Just $ URIAuth "" baseHost basePort) "/"
85 | in base (routeToQuery r) "" --TODO: https
86 |
87 | -- | Constructs a query string containing json-encoded route information.
88 | -- Seriously, use 'Obelisk.Route' instead.
89 | routeToQuery :: (ToJSON r, Default r, Eq r) => r -> String
90 | routeToQuery r = if r == def
91 | then ""
92 | else T.unpack . decodeUtf8 $ renderQuery True [("x", Just $ LBS.toStrict $ encode r)]
93 |
94 | instance MonadRoute r m => MonadRoute r (ReaderT a m) where
95 | routeToUrl r = lift $ routeToUrl r
96 |
97 | instance MonadRoute r m => MonadRoute r (MaybeT m) where
98 | routeToUrl r = lift $ routeToUrl r
99 |
100 | instance MonadRoute r m => MonadRoute r (ExceptT a m) where
101 | routeToUrl r = lift $ routeToUrl r
102 |
103 | -- | A transformer that can produce route information for a subset of routes
104 | newtype SubRouteT r r' m a = SubRouteT (ReaderT (r' -> r) m a)
105 | deriving (Functor, Applicative, Monad, MonadIO)
106 |
107 | instance (MonadRoute r m) => MonadRoute r' (SubRouteT r r' m) where
108 | routeToUrl r = SubRouteT $ do
109 | routeConv <- ask
110 | lift $ routeToUrl $ routeConv r
111 |
112 | instance MonadTrans (SubRouteT r r') where
113 | lift = SubRouteT . lift
114 |
115 | -- | Runs a 'SubRouteT' action
116 | runSubRouteT :: SubRouteT r r' m a -> (r' -> r) -> m a
117 | runSubRouteT (SubRouteT a) = runReaderT a
118 |
119 | -- | Produce urls for a subdomain
120 | routeToSubdomainUrl :: (MonadRoute r m) => String -> r -> m URI
121 | routeToSubdomainUrl sub x = fmap (addSubdomain sub) (routeToUrl x)
122 |
123 | -- | Tacks a subdomain onto a given 'URI"
124 | addSubdomain :: String -> URI -> URI
125 | addSubdomain sub uri = uri
126 | { uriAuthority = fmap
127 | (\auth -> auth { uriRegName = sub ++ "." ++ uriRegName auth })
128 | (uriAuthority uri)
129 | }
130 |
131 | -- | Get the json-encoded query parameter used by this module to store and
132 | -- convey route infromation
133 | getDefaultParam :: FromJSON b => Map BS.ByteString (Maybe BS.ByteString) -> Maybe b
134 | getDefaultParam params = do
135 | Just v <- Map.lookup (encodeUtf8 "x") params
136 | decodeStrict' v
137 |
138 | -- | JSON-decode route information
139 | decodeRoute :: (FromJSON r) => T.Text -> Maybe r
140 | decodeRoute t = do
141 | Just v <- Map.lookup (encodeUtf8 "x") (Map.fromList (parseQuery (encodeUtf8 t)))
142 | decodeStrict' v
143 |
144 | -- | Constructs a 'RouteEnv' object from a 'URI'.
145 | uriToRouteEnv
146 | :: URI
147 | -> Maybe RouteEnv
148 | uriToRouteEnv u = do
149 | let s = uriScheme u
150 | a <- uriAuthority u
151 | return (s, uriUserInfo a <> uriRegName a, uriPort a <> uriPath u <> uriQuery u <> uriFragment u)
152 |
--------------------------------------------------------------------------------
/common/Rhyolite/Vessel/App.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TypeFamilies #-}
2 | {-# LANGUAGE FlexibleContexts #-}
3 | {-# LANGUAGE ConstraintKinds #-}
4 |
5 | module Rhyolite.Vessel.App where
6 |
7 | import Rhyolite.Vessel.Types
8 | import Rhyolite.Vessel.AuthenticatedV
9 | import Rhyolite.Api
10 |
11 | type RhyoliteAuthAppC app = HasRhyoliteAuth
12 | (AuthCredential app)
13 | (PublicV app)
14 | (PrivateV app)
15 | (PersonalV app)
16 |
17 | -- | optional class to help organise the types of a rhyolite authenticated app.
18 | class RhyoliteAuthAppC app => RhyoliteAuthApp app where
19 | type AuthCredential app :: *
20 |
21 | type PublicApi app :: (* -> *)
22 | type PrivateApi app :: (* -> *)
23 |
24 | type PrivateV app :: ((* -> *) -> *)
25 | type PersonalV app :: ((* -> *) -> *)
26 | type PublicV app :: ((* -> *) -> *)
27 |
28 | -- | The full view selector which has a public, private, and personal part.
29 | type FullAppV app = FullV (AuthCredential app) (PublicV app) (PrivateV app) (PersonalV app)
30 |
31 | -- | The full view selector from the point of view of a particular authenticated identity which
32 | -- may or may not be valid; the result of a query can fail.
33 | type FullAppAuthErrorV app = FullAuthErrorV (PublicV app) (PrivateV app) (PersonalV app)
34 |
35 | -- | The full view selector from the point of view of a particular authenticated identity which
36 | -- assumes that the identity is valid and so the query cannot fali.
37 | type FullAppAuthV app = AuthenticatedV (PublicV app) (PrivateV app) (PersonalV app)
38 |
39 | type FullApi app = ApiRequest (AuthCredential app) (PublicApi app) (PrivateApi app)
40 | type FullAuthApi app = ApiRequest () (PublicApi app) (PrivateApi app)
41 |
--------------------------------------------------------------------------------
/common/Rhyolite/Vessel/ErrorV.hs:
--------------------------------------------------------------------------------
1 | {-| Description: Either-like container for views and errors -}
2 | module Rhyolite.Vessel.ErrorV
3 | ( module X
4 | ) where
5 |
6 | import Rhyolite.Vessel.ErrorV.Internal as X (ErrorV)
7 | import Rhyolite.Vessel.ErrorV.Internal as X hiding (ErrorV(..))
8 |
--------------------------------------------------------------------------------
/common/Rhyolite/Vessel/ErrorV/Internal.hs:
--------------------------------------------------------------------------------
1 | {-| Description: ErrorV implementation
2 | -}
3 | {-# Language ConstraintKinds #-}
4 | {-# Language DeriveGeneric #-}
5 | {-# Language FlexibleInstances #-}
6 | {-# Language GADTs #-}
7 | {-# Language GeneralizedNewtypeDeriving #-}
8 | {-# Language LambdaCase #-}
9 | {-# Language MultiParamTypeClasses #-}
10 | {-# Language PolyKinds #-}
11 | {-# Language RankNTypes #-}
12 | {-# Language StandaloneDeriving #-}
13 | {-# Language TemplateHaskell #-}
14 | {-# Language TypeFamilies #-}
15 | {-# Language UndecidableInstances #-}
16 | module Rhyolite.Vessel.ErrorV.Internal where
17 |
18 | import Data.Aeson
19 | import Data.Aeson.GADT.TH
20 | import Data.Constraint
21 | import Data.Constraint.Extras
22 | import Data.GADT.Compare
23 | import Data.GADT.Show
24 | import Data.Orphans ()
25 | import Data.Patch
26 | import Data.Semigroup
27 | import Data.Semigroup.Commutative
28 | import Data.Type.Equality
29 | import Data.Vessel
30 | import Data.Vessel.Single
31 | import Data.Vessel.Vessel
32 | import GHC.Generics
33 | import Reflex.Query.Class
34 |
35 | import Rhyolite.App
36 |
37 | -- | An internal type which specifies the two pieces of an 'ErrorV' container.
38 | -- When constructing a query, only the View piece is present. When constructing
39 | -- a result, either the Error or View part will be present but never both.
40 | data ErrorVK err view (v :: (* -> *) -> *) where
41 | ErrorVK_Error :: ErrorVK err view (SingleV err)
42 | ErrorVK_View :: ErrorVK err view view
43 |
44 | deriveJSONGADT ''ErrorVK
45 |
46 | instance GEq (ErrorVK err view) where
47 | geq = \case
48 | ErrorVK_Error -> \case
49 | ErrorVK_Error -> Just Refl
50 | ErrorVK_View -> Nothing
51 | ErrorVK_View -> \case
52 | ErrorVK_Error -> Nothing
53 | ErrorVK_View -> Just Refl
54 |
55 | instance GCompare (ErrorVK err view) where
56 | gcompare = \case
57 | ErrorVK_Error -> \case
58 | ErrorVK_Error -> GEQ
59 | ErrorVK_View -> GLT
60 | ErrorVK_View -> \case
61 | ErrorVK_Error -> GGT
62 | ErrorVK_View -> GEQ
63 |
64 | instance (c (SingleV err), c view) => Has c (ErrorVK err view) where
65 | argDict = \case
66 | ErrorVK_Error -> Dict
67 | ErrorVK_View -> Dict
68 |
69 | deriving instance Show (ErrorVK e v a)
70 |
71 | instance GShow (ErrorVK e v) where
72 | gshowsPrec = showsPrec
73 |
74 | deriving instance (Show (v f), Show (f (First (Maybe e)))) => Show (ErrorV e v f)
75 |
76 | -- | A functor-parametric container which as a query will contain a value of the
77 | -- underlying view type and as a result may contain either an err value or a
78 | -- view result value.
79 | newtype ErrorV err view g = ErrorV { unErrorV :: Vessel (ErrorVK err view) g }
80 | deriving (Generic, EmptyView)
81 |
82 | deriving instance (Eq (g (First (Maybe err))), Eq (view g)) => Eq (ErrorV err view g)
83 |
84 | instance View view => View (ErrorV err view)
85 |
86 | instance (ToJSON (g (First (Maybe err))), ToJSON (view g)) => ToJSON (ErrorV err view g)
87 | instance (View view, FromJSON (g (First (Maybe err))), FromJSON (view g)) => FromJSON (ErrorV err view g)
88 |
89 | deriving instance (Has' Semigroup (ErrorVK err v) (FlipAp g), View v) => Semigroup (ErrorV err v g)
90 | deriving instance (Has' Semigroup (ErrorVK err v) (FlipAp g), View v) => Monoid (ErrorV err v g)
91 |
92 | deriving instance (Semigroup (g (First (Maybe err))), Semigroup (v g), View v) => Commutative (ErrorV err v g)
93 | deriving instance
94 | ( Semigroup (g (First (Maybe err)))
95 | , Group (g (First (Maybe err)))
96 | , Semigroup (v g)
97 | , Group (v g)
98 | , View v
99 | ) => Group (ErrorV err v g)
100 | deriving instance (PositivePart (g (First (Maybe err))), PositivePart (v g)) => PositivePart (ErrorV err v g)
101 |
102 | instance
103 | ( Semigroup (v Identity)
104 | , View v
105 | , QueryResult (v Proxy) ~ v Identity
106 | ) => Query (ErrorV err v Proxy) where
107 | type QueryResult (ErrorV err v Proxy) = ErrorV err v Identity
108 | crop (ErrorV s) (ErrorV r) = ErrorV $ crop s r
109 |
110 | instance
111 | ( Semigroup (v Identity)
112 | , View v
113 | , QueryResult (v (Const g)) ~ v Identity
114 | ) => Query (ErrorV err v (Const g)) where
115 | type QueryResult (ErrorV err v (Const g)) = ErrorV err v Identity
116 | crop (ErrorV s) (ErrorV r) = ErrorV $ crop s r
117 |
118 | instance
119 | ( View v
120 | , Has' Semigroup (ErrorVK err v) (FlipAp (Compose c (VesselLeafWrapper (QueryResult (Vessel (ErrorVK err v) g)))))
121 | , Query (Vessel (ErrorVK err v) g)
122 | ) => Query (ErrorV err v (Compose c g)) where
123 | type QueryResult (ErrorV err v (Compose c g)) = ErrorV err v (Compose c (VesselLeafWrapper (QueryResult (Vessel (ErrorVK err v) g))))
124 | crop (ErrorV s) (ErrorV r) = ErrorV $ crop s r
125 |
126 | -- | Construct a query that registers interest in both the success and error parts of an ErrorV.
127 | queryErrorV :: (View v, Semigroup (v Proxy)) => v Proxy -> ErrorV e v Proxy
128 | queryErrorV v = ErrorV (singletonV ErrorVK_View v <> singletonV ErrorVK_Error (SingleV Proxy))
129 |
130 | -- | Construct a query that registers interest in both the success and error parts of an ErrorV.
131 | queryErrorVConst :: (View v, Num x, Semigroup x, Semigroup (v (Const x))) => v (Const x) -> ErrorV e v (Const x)
132 | queryErrorVConst v = ErrorV (singletonV ErrorVK_View v <> singletonV ErrorVK_Error (SingleV (Const 1)))
133 |
134 | -- | The error part of the view will never be present
135 | successErrorV :: View v => v Identity -> ErrorV e v Identity
136 | successErrorV = ErrorV . singletonV ErrorVK_View
137 |
138 | -- | The successful part of the view will never be present
139 | failureErrorV :: e -> ErrorV e v Identity
140 | failureErrorV = ErrorV . singletonV ErrorVK_Error . SingleV . Identity . First . Just
141 |
142 | -- | Given an 'ErrorV' query and a way to provide a possibly failing result,
143 | -- construct an ErrorV result.
144 | buildErrorV
145 | :: (View v, Monad m)
146 | => (v Proxy -> m (Either e (v Identity)))
147 | -> ErrorV e v Proxy
148 | -> m (ErrorV e v Identity)
149 | buildErrorV f (ErrorV v) = case lookupV ErrorVK_View v of
150 | Nothing -> pure (ErrorV emptyV)
151 | Just v' -> f v' >>= \case
152 | Left err -> pure $ failureErrorV err
153 | Right val -> pure $ successErrorV val
154 |
155 | -- | Given an 'ErrorV' result, observe whether it is an error result
156 | -- or a result of the underlying view type.
157 | observeErrorV
158 | :: ErrorV e v Identity
159 | -> Maybe (Either e (v Identity))
160 | observeErrorV (ErrorV v) = case lookupV ErrorVK_Error v of
161 | Nothing -> Right <$> lookupV ErrorVK_View v
162 | Just err -> case lookupSingleV err of
163 | Nothing -> Right <$> lookupV ErrorVK_View v
164 | Just e -> Just (Left e)
165 |
166 | -- | A 'Path' which abstracts over constructing the query and observing the result.
167 | errorV :: (Semigroup (v (Const x)), View v, Num x, Semigroup x)
168 | => Path (v (Const x)) (ErrorV e v (Const x)) (ErrorV e v Identity) (Either e (v Identity))
169 | errorV = Path { _path_to = queryErrorVConst, _path_from = observeErrorV }
170 |
171 | -- | Given an 'ErrorV' result, observe both error and result
172 | -- of the underlying view type.
173 | unsafeObserveErrorV
174 | :: ErrorV e v f
175 | -> (Maybe (f (First (Maybe e))), Maybe (v f))
176 | unsafeObserveErrorV (ErrorV v) =
177 | let
178 | err = fmap unSingleV $ lookupV ErrorVK_Error v
179 | in (err, lookupV ErrorVK_View v)
180 |
--------------------------------------------------------------------------------
/common/Rhyolite/Vessel/Path.hs:
--------------------------------------------------------------------------------
1 | {-# Language FlexibleInstances #-}
2 | {-# Language FunctionalDependencies #-}
3 | {-# Language RankNTypes #-}
4 | {-# Language GADTs #-}
5 | module Rhyolite.Vessel.Path
6 | (module Rhyolite.Vessel.Path, module Data.Vessel.Path)
7 | where
8 |
9 | import Data.Map (Map)
10 | import qualified Data.Map as Map
11 | import Data.Map.Monoidal
12 | import Data.Semigroup
13 | import Data.Vessel
14 | import Data.Vessel.Path
15 | import Rhyolite.SemiMap (SemiMap, getComplete)
16 |
17 | -- | 'Path' that will process the result and extract complete SemiMaps.
18 | semiMapP :: (Traversable f) => Path x x (f (SemiMap k v)) (f (Map k v))
19 | semiMapP = postMap (traverse (fmap getMonoidalMap . getComplete))
20 |
21 | -- | 'Path' that will process the result and collapse a Map of SemiMaps to extract just those
22 | -- which are complete.
23 | semiMapsP :: (Traversable f) => Path x x (f (Map k (SemiMap k' v))) (f (Map k (Map k' v)))
24 | semiMapsP = postMap (traverse (Just . Map.mapMaybe (fmap getMonoidalMap . getComplete)))
25 |
26 | -- TODO: Move to Data.Vessel.Path
27 | -- | 'Path' that will process the result and extract a 'First'.
28 | firstP :: Traversable f => Path x x (f (First v)) (f v)
29 | firstP = postMap (traverse (Just . getFirst))
30 |
31 | -- TODO: Move to Data.Vessel.Path
32 | -- | 'Path' that will construct an empty view selector, and get nothing back.
33 | emptyPath :: Monoid m => Path a m m' a'
34 | emptyPath = Path (const mempty) (const Nothing)
35 |
--------------------------------------------------------------------------------
/common/Rhyolite/Vessel/Types.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ConstraintKinds #-}
2 | {-# LANGUAGE TypeFamilies #-}
3 |
4 | module Rhyolite.Vessel.Types where
5 |
6 | import Data.Vessel.Class
7 | import Data.Functor.Identity
8 | import Data.Functor.Const
9 | import Data.Patch (Group)
10 | import Reflex.Query.Class
11 |
12 | import Rhyolite.Vessel.AuthenticatedV
13 | import Rhyolite.Vessel.ErrorV
14 | import Rhyolite.Vessel.AuthMapV
15 |
16 | type RhyoliteAuthViewC v =
17 | ( View v
18 | , Group (v (Const SelectedCount))
19 | , Eq (v (Const SelectedCount))
20 | , Semigroup (v Identity)
21 | , QueryResult (v (Const SelectedCount)) ~ v Identity
22 | , EmptyView v
23 | )
24 |
25 | type HasRhyoliteAuth token publicV privateV personalV =
26 | ( Ord token
27 | , RhyoliteAuthViewC publicV
28 | , RhyoliteAuthViewC privateV
29 | , RhyoliteAuthViewC personalV
30 | )
31 |
32 | -- | The full view selector which has a public, private, and personal part.
33 | type FullV token publicV privateV personalV = AuthenticatedV publicV (AuthMapV token privateV) (AuthMapV token personalV)
34 |
35 | -- | The full view selector from the point of view of a particular authenticated identity which
36 | -- may or may not be valid; the result of a query can fail.
37 | type FullAuthErrorV publicV privateV personalV = AuthenticatedV publicV (ErrorV () privateV) (ErrorV () personalV)
38 |
--------------------------------------------------------------------------------
/common/Rhyolite/WebSocket.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description:
3 | Websocket protocol for requests and queries
4 |
5 | The low-level implementation of the websocket communication between
6 | frontend and backend. You can use this manually, for example, when building a
7 | program that pretends to be a user of your app (load-testing comes to mind).
8 | -}
9 |
10 | {-# Language DeriveGeneric #-}
11 | {-# Language FlexibleContexts #-}
12 | {-# Language UndecidableInstances #-}
13 |
14 | module Rhyolite.WebSocket where
15 |
16 | import Data.Aeson
17 | import Data.Semigroup ((<>))
18 | import Data.Some
19 | import Data.Text (Text)
20 | import Data.Typeable
21 | import GHC.Generics
22 | import Network.URI (URI(..))
23 | import Reflex.Query.Class
24 |
25 | -- | Given an http or file uri, guesses what the websockets uri ought to be
26 | websocketUri :: URI -> URI
27 | websocketUri uri = uri
28 | { uriScheme = case uriScheme uri of
29 | "http:" -> "ws:"
30 | "https:" -> "wss:"
31 | "file:" -> "ws:"
32 | p -> error $ "Unrecognized protocol: " <> p
33 | }
34 |
35 | -- | Represents a WebSocket message from one of two channels: ViewSelector
36 | -- declarations or API requests
37 | data WebSocketRequest q r = WebSocketRequest_ViewSelector q
38 | | WebSocketRequest_Api (TaggedRequest r)
39 | deriving (Typeable, Generic)
40 |
41 | instance (FromJSON q, FromJSON (Some r)) => FromJSON (WebSocketRequest q r)
42 | instance (ToJSON q, ToJSON (Some r)) => ToJSON (WebSocketRequest q r)
43 |
44 | -- | Represents a WebSocket response from one of three channels: incoming 'View's, API responses, or version info
45 | data WebSocketResponse q = WebSocketResponse_View (QueryResult q)
46 | | WebSocketResponse_Api TaggedResponse
47 | | WebSocketResponse_Version Text
48 | deriving (Typeable, Generic)
49 |
50 | instance FromJSON (QueryResult q) => FromJSON (WebSocketResponse q)
51 | instance ToJSON (QueryResult q) => ToJSON (WebSocketResponse q)
52 |
53 | -- | A request tagged with an identifier
54 | data TaggedRequest r = TaggedRequest Int (Some r)
55 | deriving (Typeable, Generic)
56 |
57 | instance FromJSON (Some r) => FromJSON (TaggedRequest r)
58 | instance ToJSON (Some r) => ToJSON (TaggedRequest r)
59 |
60 | -- | A response tagged with an identifier matching the one in the 'TaggedRequest'. The identifier is the first argument.
61 | data TaggedResponse = TaggedResponse Int Value
62 | deriving (Typeable, Generic)
63 |
64 | instance FromJSON TaggedResponse
65 | instance ToJSON TaggedResponse
66 |
--------------------------------------------------------------------------------
/common/rhyolite-common.cabal:
--------------------------------------------------------------------------------
1 | name: rhyolite-common
2 | version: 0.1
3 | license: BSD3
4 | copyright: Copyright (C) Obsidian Systems LLC 2018
5 | author: Obsidian Systems
6 | maintainer: maintainer@obsidian.systems
7 | stability: Experimental
8 | build-type: Simple
9 | cabal-version: >=1.2
10 | synopsis: Common abstractions and datastructures.
11 | description:
12 | This package defines some common abstractions and datatypes used by
13 | rhyolite-backend and rhyolite-frontend.
14 |
15 | library
16 | hs-source-dirs: .
17 | build-depends:
18 | aeson
19 | , aeson-gadt-th
20 | , async
21 | , attoparsec
22 | , base
23 | , base-orphans >= 0.8.6
24 | , bytestring
25 | , commutative-semigroups
26 | , constraints
27 | , constraints-extras
28 | , containers
29 | , data-default
30 | , dependent-map
31 | , dependent-monoidal-map
32 | , dependent-sum
33 | , http-types
34 | , monad-control
35 | , monoidal-containers
36 | , mtl
37 | , network-uri
38 | , patch
39 | , reflex
40 | , semialign
41 | , semimap
42 | , some
43 | , text
44 | , these
45 | , transformers
46 | , transformers-base
47 | , unordered-containers
48 | , vessel
49 | , witherable
50 |
51 | exposed-modules:
52 | Data.Vessel.Void
53 | Rhyolite.Aeson.Orphans
54 | Rhyolite.Api
55 | Rhyolite.App
56 | Rhyolite.Concurrent
57 | Rhyolite.Route
58 | Rhyolite.Vessel.AuthenticatedV
59 | Rhyolite.Vessel.AuthMapV
60 | Rhyolite.Vessel.ErrorV
61 | Rhyolite.Vessel.ErrorV.Internal
62 | Rhyolite.Vessel.Path
63 | Rhyolite.Vessel.Types
64 | Rhyolite.Vessel.App
65 | Rhyolite.WebSocket
66 |
67 | reexported-modules: aeson-gadt-th:Data.Aeson.GADT.TH as Data.Aeson.GADT
68 |
69 | if (((!os(ios) && !arch(aarch64)) && !arch(arm)) && !impl(ghcjs -any))
70 | build-depends: monad-logger
71 |
72 | ghc-options:
73 | -Wall -fno-warn-unused-do-bind -fwarn-tabs -funbox-strict-fields
74 | -O2 -fprof-auto-calls
75 |
--------------------------------------------------------------------------------
/default.nix:
--------------------------------------------------------------------------------
1 | { obelisk ? import ./dep/obelisk (builtins.removeAttrs args ["pkgs" "inNixShell"])
2 | , pkgs ? obelisk.nixpkgs
3 | , ... } @ args:
4 |
5 | let
6 | reflex-platform = obelisk.reflex-platform;
7 | inherit (pkgs) lib;
8 | haskellLib = pkgs.haskell.lib;
9 | repos = pkgs.thunkSet ./dep;
10 |
11 | # Some dependency thunks needed
12 | dep = import ./dep reflex-platform.hackGet;
13 | #TODO: Consider whether to prefer using thunkSet here.
14 |
15 | # Local packages. We override them below so that other packages can use them.
16 | rhyolitePackages = {
17 | rhyolite-backend = ./backend;
18 | rhyolite-beam-db = ./beam/db;
19 | rhyolite-beam-orphans = ./beam/orphans;
20 | rhyolite-beam-task-worker-types = ./beam/task/types;
21 | rhyolite-beam-task-worker-backend = ./beam/task/backend;
22 | rhyolite-notify-listen = ./notify-listen/notify-listen;
23 | rhyolite-notify-listen-beam = ./notify-listen/notify-listen-beam;
24 | psql-simple-class = ./psql-extras/psql-simple-class;
25 | psql-simple-beam = ./psql-extras/psql-simple-beam;
26 | psql-serializable = ./psql-extras/psql-serializable;
27 | rhyolite-common = ./common;
28 | rhyolite-email = ./email;
29 | mime-mail-orphans = ./email/mime-mail-orphans;
30 | semimap = ./semimap;
31 | rhyolite-frontend = ./frontend;
32 | signed-data = ./signed-data/signed-data;
33 | signed-data-clientsession = ./signed-data/signed-data-clientsession;
34 | rhyolite-widgets = ./widgets;
35 | rhyolite-account-backend = ./account/backend;
36 | rhyolite-account-types = ./account/types;
37 | };
38 |
39 | # srcs used for overrides
40 | overrideSrcs = rhyolitePackages // {
41 | bytestring-aeson-orphans = repos.bytestring-aeson-orphans;
42 | monoid-map = repos.monoid-map;
43 | postgresql-simple-interpolate = repos.postgresql-simple-interpolate;
44 |
45 | # Newer versions than those in reflex-platform
46 | gargoyle = repos.gargoyle + "/gargoyle";
47 | gargoyle-postgresql = repos.gargoyle + "/gargoyle-postgresql";
48 | gargoyle-postgresql-connect = repos.gargoyle + "/gargoyle-postgresql-connect";
49 | gargoyle-postgresql-nix = repos.gargoyle + "/gargoyle-postgresql-nix";
50 | push-notifications = repos.push-notifications;
51 | vessel = repos.vessel;
52 | postgresql-lo-stream = repos.postgresql-lo-stream;
53 | beam-automigrate = repos.beam-automigrate;
54 |
55 | };
56 |
57 | # You can use these manually if you don’t want to use rhyolite.project.
58 | # It will be needed if you need to combine with multiple overrides.
59 | haskellOverrides = lib.foldr lib.composeExtensions (_: _: {}) [
60 | (self: super: lib.mapAttrs (name: path: self.callCabal2nix name path {}) overrideSrcs)
61 | (self: super: {
62 | frontend = super.frontend.override {
63 | obelisk-executable-config-lookup = self.obelisk-executable-config-lookup;
64 | };
65 | gargoyle-postgresql-nix = haskellLib.overrideCabal super.gargoyle-postgresql-nix {
66 | librarySystemDepends = [ pkgs.postgresql ];
67 | };
68 | validation = haskellLib.dontCheck super.validation;
69 | postgresql-lo-stream = haskellLib.markUnbroken super.postgresql-lo-stream;
70 |
71 | HaskellNet-SSL = self.callHackage "HaskellNet-SSL" "0.3.4.4" {};
72 |
73 | base-orphans = self.callHackageDirect {
74 | pkg = "base-orphans";
75 | ver = "0.8.6";
76 | sha256 = "sha256:17hplm1mgw65jbszg5z4vqk4i24ilxv8mbszr3s8lhpll5naik26";
77 | } {};
78 |
79 | aeson-qq = self.callHackage "aeson-qq" "0.8.4" {};
80 | postgresql-syntax = haskellLib.dontCheck super.postgresql-syntax;
81 | vessel = haskellLib.doJailbreak super.vessel;
82 | monoid-map = haskellLib.doJailbreak super.monoid-map;
83 |
84 | beam-migrate = self.callHackage "beam-migrate" "0.5.2.0" {};
85 |
86 | # 'locale' is broken on nix darwin which is required by postgres 'initdb'
87 | rhyolite-beam-task-worker-backend = if pkgs.stdenv.hostPlatform.isDarwin
88 | then
89 | haskellLib.dontCheck super.rhyolite-beam-task-worker-backend
90 | else
91 | super.rhyolite-beam-task-worker-backend;
92 | })
93 | ];
94 |
95 | in obelisk // {
96 |
97 | inherit haskellOverrides;
98 |
99 | rhyolitePackages = haskellPackages: builtins.intersectAttrs rhyolitePackages (haskellPackages.extend haskellOverrides);
100 |
101 | # Function similar to obelisk.project that handles overrides for you.
102 | project = base: projectDefinition:
103 | obelisk.project base ({...}@args:
104 | let def = projectDefinition args;
105 | in def // {
106 | overrides = lib.composeExtensions haskellOverrides (def.overrides or (_: _: {}));
107 | });
108 |
109 | # Used to build this project. Should only be needed by CI, devs.
110 | proj = obelisk.reflex-platform.project ({ pkgs, ... }@args: {
111 | overrides = haskellOverrides;
112 | packages = {
113 | rhyolite-backend = ./backend;
114 | rhyolite-common = ./common;
115 | semimap = ./semimap;
116 | rhyolite-frontend = ./frontend;
117 | rhyolite-test-suite = ./test;
118 | };
119 | shells = rec {
120 | ghc = [
121 | "rhyolite-backend"
122 | "rhyolite-test-suite"
123 | ] ++ ghcjs;
124 | ghcjs = [
125 | "rhyolite-common"
126 | "rhyolite-frontend"
127 | ];
128 | };
129 | tools = ghc: [ pkgs.postgresql ];
130 | });
131 | }
132 |
--------------------------------------------------------------------------------
/dep/beam-automigrate/default.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | import (import ./thunk.nix)
--------------------------------------------------------------------------------
/dep/beam-automigrate/github.json:
--------------------------------------------------------------------------------
1 | {
2 | "owner": "obsidiansystems",
3 | "repo": "beam-automigrate",
4 | "branch": "develop",
5 | "private": false,
6 | "rev": "5bd03ad708583d7edcd5a796e7d6306bdd3919a8",
7 | "sha256": "1cl7z1srig1h7wzai583ggi4alc8ln39yrspvsagp9d94xrwads3"
8 | }
9 |
--------------------------------------------------------------------------------
/dep/beam-automigrate/thunk.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3 | if !fetchSubmodules && !private then builtins.fetchTarball {
4 | url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5 | } else (import (builtins.fetchTarball {
6 | url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
7 | sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
8 | }) {}).fetchFromGitHub {
9 | inherit owner repo rev sha256 fetchSubmodules private;
10 | };
11 | json = builtins.fromJSON (builtins.readFile ./github.json);
12 | in fetch json
--------------------------------------------------------------------------------
/dep/bytestring-aeson-orphans/default.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | import (import ./thunk.nix)
--------------------------------------------------------------------------------
/dep/bytestring-aeson-orphans/github.json:
--------------------------------------------------------------------------------
1 | {
2 | "owner": "obsidiansystems",
3 | "repo": "bytestring-aeson-orphans",
4 | "branch": "release/0.1.0.1",
5 | "private": false,
6 | "rev": "4d3c8d2344af18a0e486b07d574e41ad7e24a10c",
7 | "sha256": "17dhl97qsadn37pmvw5z9zjzwy750yis3wr88zqb1g4wfb95jv4h"
8 | }
9 |
--------------------------------------------------------------------------------
/dep/bytestring-aeson-orphans/thunk.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3 | if !fetchSubmodules && !private then builtins.fetchTarball {
4 | url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5 | } else (import (builtins.fetchTarball {
6 | url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
7 | sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
8 | }) {}).fetchFromGitHub {
9 | inherit owner repo rev sha256 fetchSubmodules private;
10 | };
11 | json = builtins.fromJSON (builtins.readFile ./github.json);
12 | in fetch json
--------------------------------------------------------------------------------
/dep/default.nix:
--------------------------------------------------------------------------------
1 | # Applies a given function to the subdirectories of this one.
2 | f: let inherit (builtins) readDir filter map listToAttrs getAttr attrNames;
3 | fs = readDir ./.;
4 | dirs = filter (x: getAttr x fs == "directory") (attrNames fs);
5 | in listToAttrs (map (d: { name = d; value = f (./. + ("/" + d)); }) dirs)
6 |
--------------------------------------------------------------------------------
/dep/gargoyle/default.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | import (import ./thunk.nix)
--------------------------------------------------------------------------------
/dep/gargoyle/github.json:
--------------------------------------------------------------------------------
1 | {
2 | "owner": "obsidiansystems",
3 | "repo": "gargoyle",
4 | "branch": "develop",
5 | "private": false,
6 | "rev": "d9a2b0ab4297d883caef784c7c11891611a6d4b0",
7 | "sha256": "1rxqvy10bgzd3bldrv223m71j3nll297llcpaiz32nyzjdw2rwik"
8 | }
9 |
--------------------------------------------------------------------------------
/dep/gargoyle/thunk.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3 | if !fetchSubmodules && !private then builtins.fetchTarball {
4 | url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5 | } else (import (builtins.fetchTarball {
6 | url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
7 | sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
8 | }) {}).fetchFromGitHub {
9 | inherit owner repo rev sha256 fetchSubmodules private;
10 | };
11 | json = builtins.fromJSON (builtins.readFile ./github.json);
12 | in fetch json
--------------------------------------------------------------------------------
/dep/monoid-map/default.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | import (import ./thunk.nix)
--------------------------------------------------------------------------------
/dep/monoid-map/github.json:
--------------------------------------------------------------------------------
1 | {
2 | "owner": "obsidiansystems",
3 | "repo": "monoid-map",
4 | "branch": "release/0.2.0.0",
5 | "private": false,
6 | "rev": "620e5353713dd292c33d71462ed0835034612d2f",
7 | "sha256": "1aszp69b3wf247cjcy3qw18qrp91hay3dg7fwm6vgzpwdbpnf0yv"
8 | }
9 |
--------------------------------------------------------------------------------
/dep/monoid-map/thunk.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3 | if !fetchSubmodules && !private then builtins.fetchTarball {
4 | url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5 | } else (import (builtins.fetchTarball {
6 | url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
7 | sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
8 | }) {}).fetchFromGitHub {
9 | inherit owner repo rev sha256 fetchSubmodules private;
10 | };
11 | json = builtins.fromJSON (builtins.readFile ./github.json);
12 | in fetch json
--------------------------------------------------------------------------------
/dep/obelisk/default.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | import (import ./thunk.nix)
--------------------------------------------------------------------------------
/dep/obelisk/github.json:
--------------------------------------------------------------------------------
1 | {
2 | "owner": "obsidiansystems",
3 | "repo": "obelisk",
4 | "branch": "release/1.3.0.0",
5 | "private": false,
6 | "rev": "58c04270d606c061e7ffd2f16345e0f451eba600",
7 | "sha256": "167h4qkkc7rvhwlfbv3fdj3gd8jn5svdawh2vzpi04j9xlsw3jlf"
8 | }
9 |
--------------------------------------------------------------------------------
/dep/obelisk/thunk.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3 | if !fetchSubmodules && !private then builtins.fetchTarball {
4 | url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5 | } else (import (builtins.fetchTarball {
6 | url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
7 | sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
8 | }) {}).fetchFromGitHub {
9 | inherit owner repo rev sha256 fetchSubmodules private;
10 | };
11 | json = builtins.fromJSON (builtins.readFile ./github.json);
12 | in fetch json
--------------------------------------------------------------------------------
/dep/postgresql-lo-stream/default.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | import (import ./thunk.nix)
--------------------------------------------------------------------------------
/dep/postgresql-lo-stream/github.json:
--------------------------------------------------------------------------------
1 | {
2 | "owner": "obsidiansystems",
3 | "repo": "postgresql-lo-stream",
4 | "branch": "develop",
5 | "private": false,
6 | "rev": "ddf9778546ac90be5d74a8009d114c041f99cffb",
7 | "sha256": "1hqrjmqmn45c7ghda7g2dqkndg7s2nsf0d9vpvhrmbim9aw9gvbr"
8 | }
9 |
--------------------------------------------------------------------------------
/dep/postgresql-lo-stream/thunk.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3 | if !fetchSubmodules && !private then builtins.fetchTarball {
4 | url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5 | } else (import (builtins.fetchTarball {
6 | url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
7 | sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
8 | }) {}).fetchFromGitHub {
9 | inherit owner repo rev sha256 fetchSubmodules private;
10 | };
11 | json = builtins.fromJSON (builtins.readFile ./github.json);
12 | in fetch json
--------------------------------------------------------------------------------
/dep/postgresql-simple-interpolate/default.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | import (import ./thunk.nix)
--------------------------------------------------------------------------------
/dep/postgresql-simple-interpolate/github.json:
--------------------------------------------------------------------------------
1 | {
2 | "owner": "obsidiansystems",
3 | "repo": "postgresql-simple-interpolate",
4 | "branch": "master",
5 | "private": false,
6 | "rev": "fc34dd4d1e179b4dd8e2fa9419435d6f9bd29160",
7 | "sha256": "0631fhycn8silm25rbajqc4fmhhh6n6kcnl6b0nddzx0bdmf1v0b"
8 | }
9 |
--------------------------------------------------------------------------------
/dep/postgresql-simple-interpolate/thunk.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3 | if !fetchSubmodules && !private then builtins.fetchTarball {
4 | url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5 | } else (import (builtins.fetchTarball {
6 | url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
7 | sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
8 | }) {}).fetchFromGitHub {
9 | inherit owner repo rev sha256 fetchSubmodules private;
10 | };
11 | json = builtins.fromJSON (builtins.readFile ./github.json);
12 | in fetch json
--------------------------------------------------------------------------------
/dep/push-notifications/default.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | import (import ./thunk.nix)
--------------------------------------------------------------------------------
/dep/push-notifications/github.json:
--------------------------------------------------------------------------------
1 | {
2 | "owner": "obsidiansystems",
3 | "repo": "push-notifications",
4 | "branch": "develop",
5 | "private": false,
6 | "rev": "7a6f836a5086c3271613fa96eee3f7a05c8e7a23",
7 | "sha256": "10kl2vpzjknqmp816rw2zmnnv01zjp2d4s2243skm70z0js0al8w"
8 | }
9 |
--------------------------------------------------------------------------------
/dep/push-notifications/thunk.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3 | if !fetchSubmodules && !private then builtins.fetchTarball {
4 | url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5 | } else (import {}).fetchFromGitHub {
6 | inherit owner repo rev sha256 fetchSubmodules private;
7 | };
8 | json = builtins.fromJSON (builtins.readFile ./github.json);
9 | in fetch json
--------------------------------------------------------------------------------
/dep/vessel/default.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | import (import ./thunk.nix)
--------------------------------------------------------------------------------
/dep/vessel/github.json:
--------------------------------------------------------------------------------
1 | {
2 | "owner": "obsidiansystems",
3 | "repo": "vessel",
4 | "branch": "release/0.3.0.0-r1",
5 | "private": false,
6 | "rev": "a0eafdd20b3844dd23e3b0ac537049c60b9049b0",
7 | "sha256": "19nn25sdr4hxvd9i81aqvx2hm7c6dg9zzb244rl21jp689nnkxqk"
8 | }
9 |
--------------------------------------------------------------------------------
/dep/vessel/thunk.nix:
--------------------------------------------------------------------------------
1 | # DO NOT HAND-EDIT THIS FILE
2 | let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3 | if !fetchSubmodules && !private then builtins.fetchTarball {
4 | url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5 | } else (import (builtins.fetchTarball {
6 | url = "https://github.com/NixOS/nixpkgs/archive/3aad50c30c826430b0270fcf8264c8c41b005403.tar.gz";
7 | sha256 = "0xwqsf08sywd23x0xvw4c4ghq0l28w2ki22h0bdn766i16z9q2gr";
8 | }) {}).fetchFromGitHub {
9 | inherit owner repo rev sha256 fetchSubmodules private;
10 | };
11 | json = builtins.fromJSON (builtins.readFile ./github.json);
12 | in fetch json
--------------------------------------------------------------------------------
/email/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | # Revision history for rhyolite-email
2 |
3 | ## 0.1.0.0 -- YYYY-mm-dd
4 |
5 | * First version. Released on an unsuspecting world.
6 |
--------------------------------------------------------------------------------
/email/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/email/mime-mail-orphans/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/email/mime-mail-orphans/mime-mail-orphans.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: mime-mail-orphans
3 | version: 0.1.0.0
4 | synopsis: Orphan instances for mime-mail
5 | homepage: https://github.com/obsidiansystems/rhyolite
6 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
7 | license: BSD-3-Clause
8 | license-file: LICENSE
9 | author: Obsidian Systems LLC
10 | maintainer: maintainer@obsidian.systems
11 | copyright: 2021 Obsidian Systems LLC
12 | category: Web
13 |
14 | library
15 | exposed-modules:
16 | Network.Mail.Mime.Orphans
17 | build-depends:
18 | base
19 | , aeson
20 | , bytestring-aeson-orphans
21 | , mime-mail
22 |
23 | hs-source-dirs: src
24 | default-language: Haskell2010
25 | ghc-options: -Wall
26 |
--------------------------------------------------------------------------------
/email/mime-mail-orphans/src/Network/Mail/Mime/Orphans.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TemplateHaskell #-}
2 | {-# LANGUAGE StandaloneDeriving #-}
3 | {-# OPTIONS_GHC -Wno-orphans #-}
4 |
5 | module Network.Mail.Mime.Orphans where
6 |
7 | import ByteString.Aeson.Orphans ()
8 | import Data.Aeson
9 | import Data.Aeson.TH
10 | import qualified Network.Mail.Mime as Mail
11 |
12 | deriveJSON defaultOptions ''Mail.Address
13 | deriveJSON defaultOptions ''Mail.Disposition
14 | deriveJSON defaultOptions ''Mail.Encoding
15 | deriveJSON defaultOptions ''Mail.Part
16 | deriveJSON defaultOptions ''Mail.PartContent
17 | deriveJSON defaultOptions ''Mail.Mail
18 |
19 | deriving instance Read Mail.Address
20 |
--------------------------------------------------------------------------------
/email/rhyolite-email.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: rhyolite-email
3 | version: 0.1.0.0
4 | synopsis: Send emails from rhyolite applications
5 | description: Send emails over SMTP and build emails using blaze or reflex-dom
6 | homepage: https://github.com/obsidiansystems/rhyolite
7 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
8 | license: BSD-3-Clause
9 | license-file: LICENSE
10 | author: Obsidian Systems LLC
11 | maintainer: maintainer@obsidian.systems
12 | copyright: 2021 Obsidian Systems LLC
13 | category: Web
14 | extra-source-files:
15 | CHANGELOG.md
16 | email.css
17 |
18 | library
19 | exposed-modules:
20 | Rhyolite.Email
21 | , Rhyolite.Email.Orphans
22 | build-depends:
23 | base
24 | , aeson
25 | , blaze-html
26 | , bytestring-aeson-orphans
27 | , data-default
28 | , file-embed
29 | , HaskellNet
30 | , HaskellNet-SSL
31 | , mime-mail
32 | , monad-logger
33 | , mtl
34 | , network
35 | , obelisk-route
36 | , reflex
37 | , reflex-dom-core
38 | , rhyolite-common
39 | , signed-data
40 | , smtp-mail
41 | , text
42 | , time
43 | , timerep
44 | , transformers
45 |
46 | hs-source-dirs: src
47 | default-language: Haskell2010
48 | ghc-options: -Wall
49 |
--------------------------------------------------------------------------------
/email/src/Rhyolite/Email.hs:
--------------------------------------------------------------------------------
1 | {-| Description: Build and send emails
2 |
3 | Utilities and templates to send emails from the backend.
4 | -}
5 |
6 | {-# Language DeriveGeneric #-}
7 | {-# Language GeneralizedNewtypeDeriving #-}
8 | {-# Language OverloadedStrings #-}
9 | {-# Language PolyKinds #-}
10 | {-# Language ScopedTypeVariables #-}
11 | {-# Language StandaloneDeriving #-}
12 | {-# Language TemplateHaskell #-}
13 | {-# Language UndecidableInstances #-}
14 |
15 | {-# OPTIONS_GHC -fno-warn-orphans #-}
16 |
17 | module Rhyolite.Email where
18 |
19 | import Control.Exception
20 | import Control.Monad.IO.Class
21 | import Control.Monad.Logger
22 | import Control.Monad.Reader (ReaderT, lift)
23 | import Control.Monad.Reader
24 | import Control.Monad.Trans.Except (ExceptT)
25 | import Control.Monad.Trans.Maybe (MaybeT)
26 | import Data.Aeson
27 | import Data.Default
28 | import Data.FileEmbed (makeRelativeToProject, embedFile)
29 | import Data.Foldable
30 | import Data.Functor.Identity (Identity, runIdentity)
31 | import Data.List.NonEmpty (NonEmpty)
32 | import Data.Maybe (maybeToList)
33 | import Data.Signed
34 | import Data.String (fromString)
35 | import Data.Text (Text)
36 | import qualified Data.Text as T
37 | import Data.Text.Encoding
38 | import qualified Data.Text.Lazy as LT
39 | import Data.Time.Clock
40 | import Data.Time.LocalTime
41 | import Data.Time.RFC2822
42 | import Data.Word
43 | import GHC.Generics (Generic)
44 | import Network.HaskellNet.Auth
45 | import Network.HaskellNet.SMTP.SSL hiding (sendMail)
46 | import qualified Network.HaskellNet.SMTP.SSL as HaskellNet
47 | import Network.Mail.Mime (Mail)
48 | import Network.Mail.Mime (Address(..), Mail(..), htmlPart, plainPart)
49 | import Network.Mail.SMTP (simpleMail)
50 | import Network.Socket (HostName, PortNumber)
51 | import Obelisk.Route.Frontend
52 | import Reflex
53 | import Reflex.Dom.Builder.Static
54 | import Rhyolite.Route
55 | import Text.Blaze.Html.Renderer.Text
56 | import Text.Blaze.Html5 ((!), Html)
57 | import qualified Text.Blaze.Html5 as H
58 | import Text.Blaze.Html5.Attributes
59 | import qualified Text.Blaze.Html5.Attributes as A
60 |
61 | -- | Errors that can arise while interacting with an SMTP server
62 | data EmailError
63 | = EmailError_AuthFailed
64 | -- ^ The SMTP server refused to authenticate
65 | | EmailError_Exception SMTPException
66 | -- ^ An error occurred while interacting with an SMTP server
67 | deriving (Generic, Show)
68 |
69 | instance Exception EmailError
70 |
71 | -- | A monad that can send emails
72 | class Monad m => MonadEmail m where
73 | sendMail :: Mail -> m (Either EmailError ())
74 |
75 | instance MonadEmail m => MonadEmail (ReaderT r m) where
76 | sendMail = lift . sendMail
77 |
78 | instance MonadEmail m => MonadEmail (MaybeT m) where
79 | sendMail = lift . sendMail
80 |
81 | instance MonadEmail m => MonadEmail (ExceptT e m) where
82 | sendMail = lift . sendMail
83 |
84 | -- TODO upstream these orphan instances
85 | deriving instance Generic AuthType
86 | instance ToJSON AuthType
87 | instance FromJSON AuthType
88 | instance FromJSON PortNumber where
89 | parseJSON v = do
90 | n :: Word16 <- parseJSON v
91 | return $ fromIntegral n
92 | instance ToJSON PortNumber where
93 | toJSON n = toJSON (fromIntegral n :: Word16)
94 |
95 | -- | SMTP connection protocols
96 | data SMTPProtocol
97 | = SMTPProtocol_Plain
98 | | SMTPProtocol_SSL
99 | | SMTPProtocol_STARTTLS
100 | deriving (Show, Read, Eq, Ord, Generic)
101 |
102 | instance FromJSON SMTPProtocol
103 | instance ToJSON SMTPProtocol
104 |
105 | -- | Configuration for how to authenticate with a mail server
106 | data EmailAuth = EmailAuth
107 | { _emailAuth_authType :: AuthType
108 | , _emailAuth_username :: Text
109 | , _emailAuth_password :: Text
110 | } deriving (Show, Eq, Generic)
111 |
112 | instance ToJSON EmailAuth
113 | instance FromJSON EmailAuth
114 |
115 | -- | Configuration for how to find an email server, and how to
116 | -- authenticate with it.
117 | data EmailConfig = EmailConfig
118 | { _emailConfig_hostname :: HostName -- ^ E.g., "smtp.server.com"
119 | , _emailConfig_port :: PortNumber
120 | , _emailConfig_protocol :: SMTPProtocol
121 | , _emailConfig_emailAuth :: Maybe EmailAuth
122 | } deriving (Show, Eq, Generic)
123 |
124 | instance ToJSON EmailConfig
125 | instance FromJSON EmailConfig
126 |
127 | -- | Send an email using the provided connection info. This function ignores
128 | -- send errors.
129 | sendEmail :: EmailConfig -> Mail -> IO (Either EmailError ())
130 | sendEmail ee m = withSMTP ee $ HaskellNet.sendMail m
131 |
132 | -- | Run an IO action that expects an active connection to an smtp server.
133 | -- The action returns an error if that connection cannot be established.
134 | withSMTP :: EmailConfig -> (SMTPConnection -> IO a) -> IO (Either EmailError a)
135 | withSMTP cfg send = do
136 | let hostname = _emailConfig_hostname cfg
137 | port = _emailConfig_port cfg
138 | go conn = case _emailConfig_emailAuth cfg of
139 | Nothing -> Right <$> send conn
140 | Just (EmailAuth authType un pw) -> do
141 | loginResult <- authenticate authType (T.unpack un) (T.unpack pw) conn
142 | if loginResult
143 | then Right <$> send conn
144 | else pure $ Left EmailError_AuthFailed
145 | er <- try $ case _emailConfig_protocol cfg of
146 | SMTPProtocol_Plain -> doSMTPPort hostname port go
147 | SMTPProtocol_STARTTLS -> doSMTPSTARTTLSWithSettings hostname (defaultSettingsSMTPSTARTTLS { sslPort = port }) go
148 | SMTPProtocol_SSL -> doSMTPSSLWithSettings hostname (defaultSettingsSMTPSSL { sslPort = port }) go
149 | case er of
150 | Left err -> pure $ Left (EmailError_Exception err)
151 | Right r -> pure $ r
152 |
153 | -- | A monad transformer that can send emails
154 | newtype EmailT m a = EmailT { unEmailT :: ReaderT EmailConfig m a }
155 | deriving
156 | ( Functor
157 | , Applicative
158 | , Monad
159 | , MonadIO
160 | , MonadRoute r
161 | , MonadSign
162 | , MonadTrans
163 | , MonadLogger
164 | )
165 |
166 | instance MonadIO m => MonadEmail (EmailT m) where
167 | sendMail mail = do
168 | env <- EmailT ask
169 | liftIO $ putStrLn $ mconcat
170 | [ "Sending email "
171 | , show (map snd $ filter ((=="Subject") . fst) $ mailHeaders mail)
172 | , " to "
173 | , show (map addressEmail $ mailTo mail)
174 | ]
175 | liftIO $ sendEmail env mail
176 |
177 | -- | Run an 'EmailT' action
178 | runEmailT :: EmailT m a -> EmailConfig -> m a
179 | runEmailT = runReaderT . unEmailT
180 |
181 | -- | Send an email, specifiying the "from" fields
182 | sendEmailFrom :: MonadEmail m
183 | => Text -- ^ Sender name
184 | -> Text -- ^ Sender email
185 | -> NonEmpty Text -- ^ Recipients
186 | -> Text -- ^ Subject line
187 | -> Html -- ^ Body of message
188 | -> m (Either EmailError ())
189 | sendEmailFrom name' email recipients sub body =
190 | sendMail $ simpleMail (Address (Just name') email)
191 | (map (Address Nothing) $ toList recipients)
192 | []
193 | []
194 | sub
195 | [htmlPart $ renderHtml body]
196 |
197 | -- | Configuration for app-specific emails
198 | data WidgetEmailCfg br fr = WidgetEmailCfg
199 | { _widgetEmailName :: Text
200 | -- ^ Name to use in the "from:" field.
201 | , _widgetEmailAddress :: Text
202 | -- ^ Email address to use in the "from:" field.
203 | , _widgetEmailBaseURL :: Text
204 | -- ^ Base URL to build URLs for
205 | , _widgetEmailRouteEncoder :: (Encoder Identity Identity (R (FullRoute br fr)) PageName)
206 | -- ^ Encoder to use for routes; usually the project's checkedRouteEncoder
207 | }
208 |
209 | -- | Build and send an email using a StaticWidget that can use frontend routes.
210 | sendWidgetEmailFrom
211 | :: forall k (x :: k) a t r br m.
212 | (MonadIO m, MonadEmail m, Reflex t)
213 | => WidgetEmailCfg br r
214 | -- ^ Configuration for email sender
215 | -> NonEmpty Text
216 | -- ^ List of recipients
217 | -> Text
218 | -- ^ Subject line
219 | -> Maybe ((RouteToUrlT (R r) Identity) Text)
220 | -- ^ Body plaintext, with route decoder
221 | -> SetRouteT t (R r) (RouteToUrlT (R r) (StaticWidget x)) a
222 | -- ^ Body widget for the email
223 | -> m (Either EmailError ())
224 | sendWidgetEmailFrom cfg recipients sub plainText bodyWidget =
225 | sendMail =<< widgetMail cfg recipients sub plainText bodyWidget
226 |
227 | -- | Build an email using a StaticWidget that can use frontend routes.
228 | widgetMail
229 | :: forall k (x :: k) a t r br m.
230 | (MonadIO m, MonadEmail m, Reflex t)
231 | => WidgetEmailCfg br r
232 | -- ^ Configuration for email sender
233 | -> NonEmpty Text
234 | -- ^ List of recipients
235 | -> Text
236 | -- ^ Subject line
237 | -> Maybe ((RouteToUrlT (R r) Identity) Text)
238 | -- ^ Body plaintext, with route decoder
239 | -> SetRouteT t (R r) (RouteToUrlT (R r) (StaticWidget x)) a
240 | -- ^ Body widget for the email
241 | -> m Mail
242 | widgetMail cfg recipients sub plainText bodyWidget = do
243 | let
244 | WidgetEmailCfg
245 | { _widgetEmailName = name'
246 | , _widgetEmailAddress = email
247 | , _widgetEmailBaseURL = baseUrl
248 | , _widgetEmailRouteEncoder = routeEncoder } = cfg
249 | renderRouteForEmail = (baseUrl <>) . renderFrontendRoute routeEncoder
250 | runEmailWidget = fmap snd . renderStatic . flip runRouteToUrlT renderRouteForEmail . runSetRouteT
251 | runEmailPlaintext = runIdentity . flip runRouteToUrlT renderRouteForEmail
252 | t <- liftIO $ getCurrentTime
253 | let formattedTime = formatTimeRFC2822 $ utcToZonedTime utc t
254 | body <- liftIO $ LT.fromStrict . decodeUtf8 <$> runEmailWidget bodyWidget
255 | let bodyText = LT.fromStrict . runEmailPlaintext <$> plainText
256 | -- XXX this can probably all be done applicatively
257 | return $ Mail
258 | (Address (Just name') email)
259 | (map (Address Nothing) $ toList recipients)
260 | []
261 | []
262 | [("Subject", sub), ("Date", formattedTime)]
263 | [maybeToList (plainPart <$> bodyText) <> [htmlPart body]]
264 |
265 | -- | A basic email template
266 | emailTemplate :: (MonadRoute r m, Default r) => Text -> Maybe Html -> Html -> Html -> Html -> m Html
267 | emailTemplate productName mStyleHtml titleHtml leadHtml contentHtml =
268 | emailTemplateSimple productName mStyleHtml titleHtml $ H.table $ do
269 | H.tr $ H.td $ H.h1 titleHtml
270 | H.hr
271 | H.tr $ H.td $ H.p ! class_ "lead" $ leadHtml
272 | H.hr
273 | H.tr $ H.td $ contentHtml
274 |
275 | -- | An email template with a predefined layout
276 | emailTemplateSimple :: (MonadRoute r m, Default r) => Text -> Maybe Html -> Html -> Html -> m Html
277 | emailTemplateSimple productName mStyleHtml titleHtml contentHtml = do
278 | indexLink <- routeToUrl def
279 | return $ H.docTypeHtml $ do
280 | H.head $ do
281 | H.style $ case mStyleHtml of
282 | Nothing -> H.toHtml $ decodeUtf8 $(embedFile =<< makeRelativeToProject "email.css")
283 | Just styleHtml -> styleHtml
284 | H.title titleHtml
285 | H.body $ H.table $ do
286 | H.tr $ H.td $ contentHtml
287 | H.tr $ H.td $ H.table $ H.tr $ H.td $ do
288 | H.hr
289 | H.p $ do
290 | H.text "Brought to you by "
291 | H.a ! A.href (fromString $ show indexLink) $ H.toHtml productName
292 |
--------------------------------------------------------------------------------
/email/src/Rhyolite/Email/Orphans.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TemplateHaskell #-}
2 | {-# LANGUAGE StandaloneDeriving #-}
3 | {-# OPTIONS_GHC -Wno-orphans #-}
4 |
5 | module Rhyolite.Email.Orphans where
6 |
7 | import ByteString.Aeson.Orphans ()
8 | import Data.Aeson
9 | import Data.Aeson.TH
10 | import qualified Network.Mail.Mime as Mail
11 |
12 | deriveJSON defaultOptions ''Mail.Address
13 | deriveJSON defaultOptions ''Mail.Disposition
14 | deriveJSON defaultOptions ''Mail.Encoding
15 | deriveJSON defaultOptions ''Mail.Part
16 | deriveJSON defaultOptions ''Mail.PartContent
17 | deriveJSON defaultOptions ''Mail.Mail
18 |
19 | deriving instance Read Mail.Address
20 |
--------------------------------------------------------------------------------
/frontend/Rhyolite/Frontend/Auth.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ScopedTypeVariables #-}
2 | {-# LANGUAGE RankNTypes #-}
3 | {-# LANGUAGE TypeFamilies #-}
4 | {-# LANGUAGE LambdaCase #-}
5 |
6 | module Rhyolite.Frontend.Auth where
7 |
8 | import Control.Category
9 | import Control.Monad.Fix
10 | import Data.Functor.Const
11 | import Prelude hiding ((.), id)
12 | import Reflex
13 |
14 | import Rhyolite.Api
15 | import Rhyolite.Frontend.App
16 | import Rhyolite.Vessel.AuthMapV
17 | import Rhyolite.Vessel.AuthenticatedV
18 | import Rhyolite.Vessel.Types
19 |
20 | -- | The type for app widgets at the top level of the app.
21 | -- Includes full Auth handling for queries and requests.
22 | type FullWidget token publicApi privateApi publicV privateV personalV =
23 | RhyoliteWidget
24 | (FullV token publicV privateV personalV (Const SelectedCount))
25 | (ApiRequest token publicApi privateApi)
26 |
27 | type FullWidgetInternal token publicApi privateApi publicV privateV personalV t m =
28 | RhyoliteWidgetInternal
29 | (FullV token publicV privateV personalV (Const SelectedCount))
30 | (ApiRequest token publicApi privateApi)
31 | t m
32 |
33 | -- | The type for app widgets that have been specialized to a particular
34 | -- authenticated identity that may or may not be valid, and so the queries
35 | -- can fail.
36 | type AuthErrorWidget token publicApi privateApi publicV privateV personalV =
37 | RhyoliteWidget
38 | (FullAuthErrorV publicV privateV personalV (Const SelectedCount))
39 | (ApiRequest () publicApi privateApi)
40 |
41 | type AuthErrorWidgetInternal token publicApi privateApi publicV privateV personalV t m =
42 | RhyoliteWidgetInternal
43 | (FullAuthErrorV publicV privateV personalV (Const SelectedCount))
44 | (ApiRequest () publicApi privateApi)
45 | t m
46 |
47 | -- | The type for app widgets that have been specialized to a particular
48 | -- authenticated identity where authentication errors have already been handled
49 | -- so the queries cannot fail within this widget.
50 | type AuthWidget token publicApi privateApi publicV privateV personalV =
51 | RhyoliteWidget
52 | (AuthenticatedV publicV privateV personalV (Const SelectedCount))
53 | (ApiRequest () publicApi privateApi )
54 |
55 | type AuthWidgetInternal token publicApi privateApi publicV privateV personalV t m =
56 | RhyoliteWidgetInternal
57 | (AuthenticatedV publicV privateV personalV (Const SelectedCount))
58 | (ApiRequest () publicApi privateApi )
59 | t m
60 |
61 | -- | Embeds a widget that uses a specific auth identity into a context where no auth identity is presumed.
62 | authenticatedWidget
63 | :: ( MonadFix m, PostBuild t m
64 | , HasRhyoliteAuth token publicV privateV personalV )
65 | => token
66 | -> AuthErrorWidget token publicApi privateApi publicV privateV personalV t m a
67 | -> FullWidget token publicApi privateApi publicV privateV personalV t m a
68 | authenticatedWidget token = mapAuth token (mapAuthenticatedV id (authMapQueryMorphism token) (authMapQueryMorphism token)) . unRhyoliteWidget
69 |
--------------------------------------------------------------------------------
/frontend/Rhyolite/Frontend/Auth/App.hs:
--------------------------------------------------------------------------------
1 | module Rhyolite.Frontend.Auth.App
2 | ( module Rhyolite.Frontend.Auth.App
3 | , module X
4 | ) where
5 |
6 | import qualified Rhyolite.Frontend.Auth as Base
7 | import Rhyolite.Vessel.App as X
8 | import Control.Monad.Fix
9 | import Reflex
10 |
11 |
12 | -- | The type for app widgets at the top level of the app.
13 | -- Includes full Auth handling for queries and requests.
14 | type FullAppWidget app =
15 | Base.FullWidget (AuthCredential app) (PublicApi app) (PrivateApi app) (PublicV app) (PrivateV app) (PersonalV app)
16 |
17 | -- | The type for app widgets that have been specialized to a particular
18 | -- authenticated identity that may or may not be valid, and so the queries
19 | -- can fail.
20 | type AuthErrorAppWidget app =
21 | Base.AuthErrorWidget (AuthCredential app) (PublicApi app) (PrivateApi app) (PublicV app) (PrivateV app) (PersonalV app)
22 |
23 | -- | The type for app widgets that have been specialized to a particular
24 | -- authenticated identity where authentication errors have already been handled
25 | -- so the queries cannot fail within this widget.
26 | type AuthAppWidget app =
27 | Base.AuthWidget (AuthCredential app) (PublicApi app) (PrivateApi app) (PublicV app) (PrivateV app) (PersonalV app)
28 |
29 | -- | Embeds a widget that uses a specific auth identity into a context where no auth identity is presumed.
30 | authenticatedWidget
31 | :: ( MonadFix m, PostBuild t m
32 | , RhyoliteAuthApp app )
33 | => proxy app
34 | -> AuthCredential app
35 | -> AuthErrorAppWidget app t m a
36 | -> FullAppWidget app t m a
37 | authenticatedWidget _ = Base.authenticatedWidget
38 |
39 |
40 |
--------------------------------------------------------------------------------
/frontend/Rhyolite/Frontend/Cookie.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description:
3 | Getting and setting cookies
4 |
5 | Getting and setting cookies on the frontend. Cookies are base64 encoded.
6 |
7 | There's some overlap between the functions in this module and
8 | Obelisk.Frontend.Cookie. That module provides 'askCookies', which can also be
9 | used to retrieve cookies. The Obelisk module has the advantage of working
10 | server-side as well, so that widgets that depend on the cookie can be
11 | prerendered. The functions in this module use javascript and, so, cannot be
12 | rendered server-side. If you're mixing the two, bear in mind that obelisk does
13 | not currently demand that cookies be base64-encoded, while this module does,
14 | so you'll have to base64-decode the result of askCookies yourself.
15 | -}
16 | {-# Language OverloadedStrings #-}
17 | {-# Language ScopedTypeVariables #-}
18 | {-# Language FlexibleContexts #-}
19 | module Rhyolite.Frontend.Cookie where
20 |
21 | import Control.Monad ((<=<))
22 | import Data.Aeson as Aeson
23 | import Data.ByteString (ByteString)
24 | import qualified Data.ByteString.Base64 as B64
25 | import Data.ByteString.Builder (toLazyByteString)
26 | import qualified Data.ByteString.Lazy as LBS
27 | import Data.Either.Combinators
28 | import Data.Text (Text)
29 | import Data.Text.Encoding
30 | import Data.Time.Calendar
31 | import Data.Time.Clock
32 | import Data.Time.Clock.POSIX
33 | import qualified GHCJS.DOM.Document as DOM
34 | import GHCJS.DOM.Types (MonadJSM)
35 | import Reflex.Dom.Core
36 | import Web.Cookie
37 |
38 | -- | "To maximize compatibility with user agents, servers that wish to
39 | -- store arbitrary data in a cookie-value SHOULD encode that data, for
40 | -- example, using Base64"
41 | --
42 | base64EncodeCookie
43 | :: SetCookie
44 | -> SetCookie
45 | base64EncodeCookie c = c { setCookieValue = B64.encode (setCookieValue c) }
46 |
47 | -- | A synonym for Data.ByteString.Base64.decode because there are too many
48 | -- functions called "decode".
49 | base64Decode :: ByteString -> Either String ByteString
50 | base64Decode = B64.decode
51 |
52 | -- | Set or clear the given cookie permanently
53 | --
54 | -- Example:
55 | -- > setPermanentCookie doc =<< defaultCookie "key" (Just "value")
56 | setPermanentCookie :: (MonadJSM m) => DOM.Document -> SetCookie -> m ()
57 | setPermanentCookie doc cookie = do
58 | DOM.setCookie doc $ decodeUtf8 $ LBS.toStrict $ toLazyByteString $ renderSetCookie $ base64EncodeCookie cookie
59 |
60 | -- | Set or clear the given cookie with given expiration date
61 | --
62 | -- Example:
63 | -- > setExpiringCookie time doc =<< defaultCookie "key" (Just "value")
64 | setExpiringCookie :: (MonadJSM m) => UTCTime -> DOM.Document -> SetCookie -> m ()
65 | setExpiringCookie timestamp doc cookie = do
66 | DOM.setCookie doc $ decodeUtf8 $ LBS.toStrict $ toLazyByteString $ renderSetCookie $ base64EncodeCookie cookie {setCookieExpires = Just timestamp}
67 |
68 | -- | Make a cookie with sensible defaults
69 | defaultCookie
70 | :: (MonadJSM m)
71 | => Text -- ^ Cookie key
72 | -> Maybe Text -- ^ Cookie value (Nothing clears it)
73 | -> m SetCookie
74 | defaultCookie key mv = do
75 | currentProtocol <- Reflex.Dom.Core.getLocationProtocol
76 | pure $ case mv of
77 | Nothing -> def
78 | { setCookieName = encodeUtf8 key
79 | , setCookieValue = ""
80 | , setCookieExpires = Just $ posixSecondsToUTCTime 0
81 | }
82 | Just val -> def
83 | { setCookieName = encodeUtf8 key
84 | , setCookieValue = encodeUtf8 val
85 | -- We don't want these to expire, but browsers don't support
86 | -- non-expiring cookies. Some systems have trouble representing dates
87 | -- past 2038, so use 2037.
88 | , setCookieExpires = Just $ UTCTime (fromGregorian 2037 1 1) 0
89 | , setCookieSecure = currentProtocol == "https:"
90 | -- This helps prevent CSRF attacks; we don't want strict, because it
91 | -- would prevent links to the page from working; lax is secure enough,
92 | -- because we don't take dangerous actions simply by executing a GET
93 | -- request.
94 | , setCookieSameSite = if currentProtocol == "file:"
95 | then Nothing
96 | else Just sameSiteLax
97 | }
98 |
99 | -- | JSON encode some data and set it as a cookie
100 | defaultCookieJson :: (MonadJSM m, ToJSON v) => Text -> Maybe v -> m SetCookie
101 | defaultCookieJson k = defaultCookie k . fmap (decodeUtf8 . LBS.toStrict . encode)
102 |
103 | -- | Set a cookie with the given domain location: see
104 | --
105 | -- for @;domain=domain@
106 | setPermanentCookieWithLocation :: (MonadJSM m) => DOM.Document -> Maybe ByteString -> Text -> Maybe Text -> m ()
107 | setPermanentCookieWithLocation doc loc key mv = do
108 | cookie <- defaultCookie key mv
109 | setPermanentCookie doc $ cookie { setCookieDomain = loc }
110 |
111 | data GetCookieFailed
112 | = GetCookieFailed_NotFound
113 | | GetCookieFailed_Base64DecodeFailed String
114 |
115 | -- | Retrieve the value of the given cookie
116 | getCookie :: MonadJSM m => DOM.Document -> Text -> m (Either GetCookieFailed Text)
117 | getCookie doc key = do
118 | cookieString <- encodeUtf8 <$> DOM.getCookie doc
119 | pure $ case lookup (encodeUtf8 key) $ parseCookies cookieString of
120 | Nothing -> Left GetCookieFailed_NotFound
121 | Just c -> mapBoth GetCookieFailed_Base64DecodeFailed decodeUtf8 $
122 | base64Decode c
123 |
124 | -- | JSON encode some data and set it as a permanent cookie
125 | setPermanentCookieJson :: (MonadJSM m, ToJSON v) => DOM.Document -> Text -> Maybe v -> m ()
126 | setPermanentCookieJson d k = setPermanentCookie d <=< defaultCookieJson k
127 |
128 | data GetCookieJsonFailed
129 | = GetCookieJsonFailed_GetCookieFailed GetCookieFailed
130 | | GetCookieJsonFailed_ParseFailure String
131 |
132 | -- | Read a cookie. You may want to use 'Obelisk.Frontend.Cookie.askCookies'
133 | -- along with 'base64Decode' instead.
134 | getCookieJson :: (FromJSON v, MonadJSM m) => DOM.Document -> Text -> m (Either GetCookieJsonFailed v)
135 | getCookieJson d k = do
136 | r <- fmap (eitherDecode . LBS.fromStrict . encodeUtf8) <$> getCookie d k
137 | pure $ case r of
138 | Left failure -> Left $ GetCookieJsonFailed_GetCookieFailed failure
139 | Right (Left parseFailure) -> Left $ GetCookieJsonFailed_ParseFailure parseFailure
140 | Right (Right v) -> Right v
141 |
142 | -- | Get a cookie and run an action on it. Set the cookie value to the result
143 | -- of the action.
144 | withPermanentCookieJson ::
145 | ( MonadJSM m
146 | , MonadJSM (Performable m)
147 | , PerformEvent t m
148 | , ToJSON v
149 | , FromJSON v
150 | )
151 | => DOM.Document
152 | -> Text
153 | -> (Either GetCookieJsonFailed v -> m (Event t (Maybe v)))
154 | -> m ()
155 | withPermanentCookieJson d k a = do
156 | cookie0 <- getCookieJson d k
157 | cookieE <- a cookie0
158 | performEvent_ $ setPermanentCookieJson d k <$> cookieE
159 | return ()
160 |
--------------------------------------------------------------------------------
/frontend/rhyolite-frontend.cabal:
--------------------------------------------------------------------------------
1 | name: rhyolite-frontend
2 | version: 0.1
3 | license: BSD3
4 | copyright: Copyright (C) Obsidian Systems LLC 2018
5 | author: Obsidian Systems LLC
6 | maintainer: maintainer@obsidian.systems
7 | stability: Experimental
8 | build-type: Simple
9 | cabal-version: >=1.2
10 | synopsis: Build apps that use a rhyolite backend as a datasource
11 | description:
12 | Rhyolite frontend apps are typically obelisk- and reflex-based applications that need live-updating data from the backend. This package provides the adapters necessary to work with requests and streaming data from a rhyolite backend.
13 |
14 | library
15 | hs-source-dirs: .
16 |
17 | if impl(ghcjs -any)
18 | build-depends: ghcjs-base
19 |
20 | build-depends:
21 | aeson
22 | , base
23 | , bytestring
24 | , base64-bytestring
25 | , commutative-semigroups
26 | , constraints
27 | , constraints-extras
28 | , containers
29 | , cookie
30 | , data-default
31 | , either
32 | , exception-transformers
33 | , ghcjs-dom
34 | , jsaddle
35 | , lens
36 | , mtl
37 | , network-uri
38 | , obelisk-executable-config-lookup
39 | , obelisk-frontend
40 | , obelisk-route
41 | , primitive
42 | , ref-tf
43 | , reflex
44 | , reflex-dom-core
45 | , rhyolite-common
46 | , some
47 | , text
48 | , time
49 | , transformers
50 | , validation
51 | , vessel
52 | , witherable
53 |
54 | exposed-modules:
55 | Rhyolite.Frontend.App
56 | Rhyolite.Frontend.Cookie
57 | Rhyolite.Frontend.Auth
58 | Rhyolite.Frontend.Auth.App
59 |
60 | ghc-options:
61 | -Wall -fno-warn-unused-do-bind -fwarn-tabs -funbox-strict-fields
62 | -O2 -fprof-auto-calls -fexpose-all-unfoldings
63 |
--------------------------------------------------------------------------------
/gen-docs.sh:
--------------------------------------------------------------------------------
1 | pkgdb=$(ghc-pkg list | head -1)
2 | rev=$(git rev-parse HEAD | cut -c1-8)
3 | tmpdir=$(mktemp -d -t rhyo-docs-$rev-XXXXXX)
4 |
5 | function cleanup {
6 | rm -rf "$tmpdir"
7 | }
8 |
9 | trap cleanup EXIT
10 |
11 | standalone-haddock \
12 | --package-db "$pkgdb" \
13 | --dist-dir "$tmpdir" \
14 | -o rhyolite-docs-$rev \
15 | backend \
16 | common \
17 | email \
18 | frontend \
19 | notify-listen/notify-listen/ \
20 | notify-listen/notify-listen-beam/ \
21 | psql-extras/psql-serializable/ \
22 | psql-extras/psql-simple-beam/ \
23 | psql-extras/psql-simple-class/ \
24 | semimap/ \
25 | signed-data/signed-data/ \
26 | signed-data/signed-data-clientsession/ \
27 | widgets/ \
28 | account/types \
29 | account/backend
30 | # groundhog-legacy/groundhog-legacy \
31 | # groundhog-legacy/groundhog-legacy-types/ \
32 | # psql-extras/psql-simple-groundhog/ \
33 |
34 |
35 |
--------------------------------------------------------------------------------
/notify-listen/notify-listen-beam/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | # Revision history for rhyolite-notify-listen-beam
2 |
3 | ## Unreleased
4 |
5 | * Add some new combinators for working with an {insert, update, delete} statement that returns arbitrary data
6 |
7 | * Breaking changes:
8 | * Change the type of deleteAndNotify to account for deletions that can fail.
9 |
10 | ## 0.1.0.0
11 |
12 | * First version. Released on an unsuspecting world.
13 |
--------------------------------------------------------------------------------
/notify-listen/notify-listen-beam/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/notify-listen/notify-listen-beam/rhyolite-notify-listen-beam.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: rhyolite-notify-listen-beam
3 | version: 0.1.0.0
4 | synopsis:
5 |
6 | -- A longer description of the package.
7 | -- description:
8 | homepage:
9 |
10 | -- A URL where users can report bugs.
11 | -- bug-reports:
12 | license: BSD-3-Clause
13 | license-file: LICENSE
14 | author: Obsidian Systems LLC
15 | maintainer: maintainer@obsidian.systems
16 |
17 | -- A copyright notice.
18 | -- copyright:
19 | category: Database
20 | extra-source-files: CHANGELOG.md
21 |
22 | library
23 | exposed-modules: Rhyolite.DB.NotifyListen.Beam
24 | build-depends:
25 | , aeson
26 | , base
27 | , beam-core
28 | , beam-postgres
29 | , constraints
30 | , constraints-extras
31 | , dependent-sum
32 | , psql-simple-beam
33 | , psql-simple-class
34 | , rhyolite-common
35 | , rhyolite-notify-listen
36 | , these
37 |
38 | hs-source-dirs: src
39 | default-language: Haskell2010
40 |
--------------------------------------------------------------------------------
/notify-listen/notify-listen/rhyolite-notify-listen.cabal:
--------------------------------------------------------------------------------
1 | name: rhyolite-notify-listen
2 | version: 0.1.0.0
3 | license: BSD3
4 | copyright: Copyright (C) Obsidian Systems LLC 2021
5 | author: Obsidian Systems LLC
6 | maintainer: maintainer@obsidian.systems
7 | stability: Experimental
8 | build-type: Simple
9 | cabal-version: >=1.2
10 | description: Notification mechanism using postgres.
11 |
12 | library
13 | hs-source-dirs: src
14 | build-depends:
15 | aeson
16 | , base
17 | , bytestring
18 | , constraints
19 | , constraints-extras
20 | , dependent-sum
21 | , dependent-sum-aeson-orphans
22 | , postgresql-simple
23 | , psql-simple-class
24 | , resource-pool
25 | , split
26 | , stm
27 | , text
28 |
29 | exposed-modules: Rhyolite.DB.NotifyListen
30 | ghc-options:
31 | -Wall -fno-warn-unused-do-bind -fwarn-tabs -funbox-strict-fields
32 | -O2 -fprof-auto-calls
33 |
--------------------------------------------------------------------------------
/notify-listen/notify-listen/src/Rhyolite/DB/NotifyListen.hs:
--------------------------------------------------------------------------------
1 | {-|
2 | Description: DB notifications
3 |
4 | Use the postgres NOTIFY/LISTEN commands to distribute information about updates
5 | to the database.
6 | -}
7 | {-# Language DeriveGeneric #-}
8 | {-# Language FlexibleContexts #-}
9 | {-# Language GADTs #-}
10 | {-# Language GeneralizedNewtypeDeriving #-}
11 | {-# Language OverloadedStrings #-}
12 | {-# Language ScopedTypeVariables #-}
13 | {-# Language StandaloneDeriving #-}
14 | {-# Language UndecidableInstances #-}
15 |
16 | module Rhyolite.DB.NotifyListen
17 | ( -- * Sending notifications
18 | notify
19 | , notify'
20 | , NotificationType(..)
21 | , DbNotification(..)
22 | -- * Running a notification listener
23 | , notificationListener
24 | , startNotificationListener
25 | , NotificationChannel(..)
26 | , defaultNotificationChannel
27 | -- * Helpers
28 | , listenCmd
29 | , notifyCmd
30 | , SchemaName(..)
31 | , getSchemaName
32 | , getSearchPath
33 | ) where
34 |
35 | import Control.Concurrent (forkIO, killThread)
36 | import Control.Concurrent.STM (TChan)
37 | import qualified Control.Concurrent.STM as STM
38 | import Control.Monad (forever)
39 | import Data.Aeson (FromJSON, ToJSON, encode, decodeStrict')
40 | import qualified Data.ByteString as BS
41 | import qualified Data.ByteString.Lazy as LBS
42 | import Data.Constraint.Extras
43 | import Data.Constraint.Forall
44 | import Data.Dependent.Sum (DSum(..))
45 | import Data.Dependent.Sum.Orphans ()
46 | import Data.Functor.Identity (Identity(..))
47 | import Data.List.Split (wordsBy)
48 | import Data.Maybe (listToMaybe)
49 | import Data.Pool (Pool, withResource)
50 | import Data.Some (Some)
51 | import Data.String (fromString)
52 | import Data.Text (Text)
53 | import qualified Data.Text as T
54 | import qualified Data.Text.Encoding as T
55 | import Data.Typeable
56 | import qualified Database.PostgreSQL.Simple as PG
57 | import Database.PostgreSQL.Simple.Class
58 | import qualified Database.PostgreSQL.Simple.Notification as PG
59 | import GHC.Generics (Generic)
60 |
61 | -- | Wrapper for the name of the channel over which notifications are sent
62 | newtype NotificationChannel
63 | = NotificationChannel { unNotificationChannel :: String }
64 |
65 | -- | The channel name (@"updates"@) used for insert/update/delete
66 | -- notifications.
67 | defaultNotificationChannel :: NotificationChannel
68 | defaultNotificationChannel = NotificationChannel "updates"
69 |
70 | -- | Constructs a @LISTEN@ command with the given channel name
71 | listenCmd :: NotificationChannel -> PG.Query
72 | listenCmd (NotificationChannel chan) = fromString $ "LISTEN " <> chan
73 |
74 | -- | Starts a thread to receive messages about changes to the database via the
75 | -- postgres @LISTEN@ mechanism.
76 | notificationListener
77 | :: (FromJSON notifyMessage)
78 | => Pool PG.Connection
79 | -- ^ Connection pool
80 | -> IO (TChan notifyMessage, IO ())
81 | -- ^ @notifyMessage@ is usually a 'DbNotification'
82 | notificationListener db = do
83 | nChan <- STM.newBroadcastTChanIO
84 | daemonThread <- forkIO $ withResource db $ \conn -> do
85 | let cmd = listenCmd defaultNotificationChannel
86 | _ <- PG.execute_ conn cmd
87 | forever $ do
88 | -- Handle notifications
89 | PG.Notification _ channel message <- PG.getNotification conn
90 | case channel of
91 | _ | channel == channelToByteString defaultNotificationChannel -> do
92 | -- Notification is on the expected NOTIFY channel
93 | case decodeStrict' message of
94 | Just a -> STM.atomically $ STM.writeTChan nChan a
95 | _ -> putStrLn $ errorMessage defaultNotificationChannel $
96 | "Could not parse message: " <> show message
97 | _ -> putStrLn $ errorMessage defaultNotificationChannel $
98 | "Received a message on unexpected channel: " <> show channel
99 | return (nChan, killThread daemonThread)
100 | where
101 | channelToByteString :: NotificationChannel -> BS.ByteString
102 | channelToByteString = T.encodeUtf8 . T.pack . unNotificationChannel
103 | errorMessage :: NotificationChannel -> String -> String
104 | errorMessage (NotificationChannel c) err =
105 | "notificationListener: channel \"" <> c <> "\": " <> err
106 |
107 | -- | Starts a thread that listens for updates to the db and returns a
108 | -- 'DbNotification' retrieval function and finalizer
109 | startNotificationListener
110 | :: FromJSON notifyMessage
111 | => Pool PG.Connection
112 | -> IO (IO notifyMessage, IO ())
113 | startNotificationListener pool = do
114 | (chan, nkill) <- notificationListener pool
115 | chan' <- STM.atomically $ STM.dupTChan chan
116 | return (STM.atomically $ STM.readTChan chan', nkill)
117 |
118 | -- | Get the schema name out of the current @search_path@
119 | getSchemaName :: Psql m
120 | => m String
121 | getSchemaName = do
122 | searchPath <- getSearchPath
123 | let searchPathComponents = wordsBy (==',') searchPath
124 | schemaName = case searchPathComponents of
125 | (x:_:_:_) -> x
126 | _ -> "public"
127 | return schemaName
128 |
129 | -- | Get the current @search_path@
130 | getSearchPath :: Psql m => m String
131 | getSearchPath = do
132 | rows <- query_ "SHOW search_path"
133 | case listToMaybe rows of
134 | Nothing -> error "getSearchPath: Unexpected result from queryRaw"
135 | Just (PG.Only searchPath) -> return searchPath
136 |
137 | -- | Used to indicate whether a given notification is an insert, update, or
138 | -- deletion. Deletions, for instance, may require special handling, as the
139 | -- deleted data will no longer be in the database.
140 | data NotificationType
141 | = NotificationType_Insert
142 | | NotificationType_Update
143 | | NotificationType_Delete
144 | deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
145 |
146 | instance ToJSON NotificationType
147 | instance FromJSON NotificationType
148 |
149 | -- | A notification payload.
150 | data DbNotification n = DbNotification
151 | { _dbNotification_schemaName :: SchemaName
152 | -- ^ The schema that was updated
153 | , _dbNotification_notificationType :: NotificationType
154 | -- ^ Whether this is an insert, update, or delete
155 | , _dbNotification_message :: DSum n Identity
156 | -- ^ The notification message itself. The notification protocol is defined as
157 | -- a GADT. See 'notify'.
158 | } deriving (Generic)
159 |
160 | deriving instance (Show (DSum n Identity)) => Show (DbNotification n)
161 |
162 | instance
163 | ( Has' ToJSON n Identity
164 | , ForallF ToJSON n
165 | )
166 | => ToJSON (DbNotification n)
167 |
168 | instance
169 | ( Has' FromJSON n Identity
170 | , FromJSON (Some n)
171 | ) => FromJSON (DbNotification n)
172 |
173 | -- | Constructs a @NOTIFY@ command with the given channel name
174 | notifyCmd :: NotificationChannel -> PG.Query
175 | notifyCmd (NotificationChannel chan) = fromString $ "NOTIFY " <> chan <> ", ?"
176 |
177 | -- | Sends a notification over a given channel. Notification payloads must have
178 | -- a JSON representation for transmission.
179 | --
180 | -- The notification message itself is wrapped in a 'DSum' to allow messages of
181 | -- different types. To use this, construct a GADT that defines your
182 | -- notification protocol:
183 | --
184 | -- > data Notify a where
185 | -- > Notify_Account :: Notify (Id Account)
186 | -- > Notify_Chatroom :: Notify (Id Chatroom)
187 | -- > Notify_Message :: Notify (Id Message)
188 | --
189 | -- Now, you can use the GADT constructor that corresponds to the particular
190 | -- notification payload type you'd like to send. For example, here's an
191 | -- invocation that sends a notification that a new account has been created:
192 | --
193 | -- > notify myChan conn NotificationType_Insert Notify_Account accountId
194 | --
195 | -- NB: The maximum payload size is 8000 bytes (this is currently neither
196 | -- checked nor enforced in this library):
197 | --
198 | -- > The "payload" string to be communicated along with the notification. This
199 | -- > must be specified as a simple string literal. In the default configuration
200 | -- > it must be shorter than 8000 bytes. (If binary data or large amounts of
201 | -- > information need to be communicated, it's best to put it in a database table
202 | -- > and send the key of the record.)
203 | -- (Source: https://www.postgresql.org/docs/9.0/sql-notify.html)
204 | notify
205 | :: ( Has' ToJSON notice Identity
206 | , ForallF ToJSON notice
207 | , Psql m
208 | )
209 | => NotificationType
210 | -> notice a
211 | -> a
212 | -> m ()
213 | notify nt n a = notify' nt (n :=> Identity a)
214 |
215 | -- | Variation of 'notify' which takes the notification tag and payload already combined
216 | -- as a 'DSum'
217 | notify'
218 | :: ( Has' ToJSON notice Identity
219 | , ForallF ToJSON notice
220 | , Psql m
221 | )
222 | => NotificationType
223 | -> DSum notice Identity
224 | -> m ()
225 | notify' nt na = do
226 | schemaName <- getSchemaName
227 | let cmd = notifyCmd defaultNotificationChannel
228 | notifyMsg = DbNotification
229 | { _dbNotification_schemaName = SchemaName $ T.pack schemaName
230 | , _dbNotification_notificationType = nt
231 | , _dbNotification_message = na
232 | }
233 | _ <- execute cmd
234 | [ T.unpack $ T.decodeUtf8 $ LBS.toStrict $ encode notifyMsg
235 | ]
236 | return ()
237 |
238 | -- | Wrapper for database schema names
239 | newtype SchemaName = SchemaName { unSchemaName :: Text }
240 | deriving (Eq, Ord, Read, Show, FromJSON, ToJSON, Typeable, Generic)
241 |
--------------------------------------------------------------------------------
/psql-extras/psql-serializable/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/psql-extras/psql-serializable/psql-serializable.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: psql-serializable
3 | version: 0.1.0.0
4 | synopsis: A monad for transactions with serializable isolation level
5 | homepage: https://github.com/obsidiansystems/rhyolite
6 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
7 | license: BSD-3-Clause
8 | license-file: LICENSE
9 | author: Obsidian Systems LLC
10 | maintainer: maintainer@obsidian.systems
11 | copyright: 2021 Obsidian Systems LLC
12 | category: Database
13 |
14 | library
15 | exposed-modules: Database.PostgreSQL.Serializable
16 | build-depends:
17 | , base
18 | , bytestring
19 | , exceptions
20 | , monad-logger
21 | , monad-logger-extras
22 | , mtl
23 | , postgresql-simple
24 | , psql-simple-class
25 | , resource-pool
26 | , transformers
27 | , transformers-base
28 |
29 | hs-source-dirs: src
30 | default-language: Haskell2010
31 | ghc-options: -Wall
32 |
--------------------------------------------------------------------------------
/psql-extras/psql-serializable/src/Database/PostgreSQL/Serializable.hs:
--------------------------------------------------------------------------------
1 | {-# Language FlexibleInstances #-}
2 | {-# Language GeneralizedNewtypeDeriving #-}
3 | {-# Language MultiParamTypeClasses #-}
4 | {-# Language QuantifiedConstraints #-}
5 | {-# Language ScopedTypeVariables #-}
6 | {-# Language RankNTypes #-}
7 | module Database.PostgreSQL.Serializable
8 | ( Serializable
9 | , unsafeMkSerializable
10 | , unSerializable
11 | , runSerializable
12 | , runSerializableInsideTransaction
13 | , unsafeHoistCoerceFromReaderT
14 | ) where
15 |
16 | import Control.Monad.Base (MonadBase (liftBase))
17 | import Control.Monad.Catch (MonadThrow)
18 | import Control.Monad.IO.Class
19 | import Control.Monad.Logger
20 | import Control.Monad.Logger.Extras
21 | import Control.Monad.Trans.Reader
22 | import Data.Coerce
23 | import Data.Pool
24 | import qualified Database.PostgreSQL.Simple as Pg
25 | import Database.PostgreSQL.Simple.Class
26 | import qualified Database.PostgreSQL.Simple.Transaction as Pg
27 |
28 | -- | A monad for database transactions with serializable isolation level.
29 | --
30 | -- Because this monad may retry execution of code automatically, it does not lawfully lift any effects other
31 | -- than Reader, which it commutes with, so there is no gain in having it be a transformer.
32 | --
33 | -- It "disallows" (makes harder) arbitrary IO.
34 | -- It "disallows" (makes harder) catching IO exceptions *inside* the transaction.
35 | newtype Serializable a = Serializable (ReaderT Pg.Connection (LoggingT IO) a)
36 | deriving (Functor, Applicative, Monad, MonadThrow, MonadLogger)
37 | -- NOTE: We *intentionally* leave out
38 | -- - 'MonadCatch' so you can't accidentally mask a serialization error from the outer retry logic.
39 | -- - 'MonadBaseControl' (et al) for the same reason.
40 | -- - 'MonadIO' so you can't execute arbitrary IO.
41 |
42 | instance MonadBase Serializable Serializable where
43 | liftBase = id
44 |
45 | unsafeMkSerializable :: ReaderT Pg.Connection (LoggingT IO) a -> Serializable a
46 | unsafeMkSerializable = Serializable
47 |
48 | unSerializable :: Serializable a -> ReaderT Pg.Connection (LoggingT IO) a
49 | unSerializable (Serializable m) = m
50 |
51 | runSerializable :: forall a m. (MonadIO m) => Pool Pg.Connection -> Logger -> Serializable a -> m a
52 | runSerializable pool logger (Serializable act) = liftIO $ withResource pool $ \c ->
53 | Pg.withTransactionSerializable c $
54 | runLoggerLoggingT (runReaderT act c) logger
55 |
56 | -- | Run a @Serializable@ inside a Postgres Transaction. Note that this function does not create a transaction on
57 | -- its own, that responsibility lies with the function that invokes it.
58 | runSerializableInsideTransaction :: forall a m. (MonadIO m) => Pg.Connection -> Logger -> Serializable a -> m a
59 | runSerializableInsideTransaction conn logger (Serializable act) = liftIO $ runLoggerLoggingT (runReaderT act conn) logger
60 |
61 | unsafeHoistCoerceFromReaderT :: forall f. (forall a b. Coercible a b => Coercible (f a) (f b)) => f (ReaderT Pg.Connection (LoggingT IO)) -> f Serializable
62 | unsafeHoistCoerceFromReaderT = coerce
63 |
64 | instance Psql Serializable where
65 | askConn = Serializable ask
66 | execute p q = Serializable $ do
67 | conn <- ask
68 | liftIO $ Pg.execute conn p q
69 | execute_ q = Serializable $ ask >>= \conn -> liftIO $ Pg.execute_ conn q
70 | executeMany p q = Serializable $ ask >>= \conn -> liftIO $ Pg.executeMany conn p q
71 | query p q = Serializable $ ask >>= \conn -> liftIO $ Pg.query conn p q
72 | query_ q = Serializable $ ask >>= \conn -> liftIO $ Pg.query_ conn q
73 | queryWith parser p q = Serializable $ ask >>= \conn -> liftIO $ Pg.queryWith parser conn p q
74 | queryWith_ parser q = Serializable $ ask >>= \conn -> liftIO $ Pg.queryWith_ parser conn q
75 | formatQuery p q = Serializable $ ask >>= \conn -> liftIO $ Pg.formatQuery conn p q
76 | returning p q = Serializable $ ask >>= \conn -> liftIO $ Pg.returning conn p q
77 |
--------------------------------------------------------------------------------
/psql-extras/psql-simple-beam/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | # Revision history for psql-simple-beam
2 |
3 | ## 0.1.0.0
4 |
5 | * Create Psql instance for beam's `Pg`
6 |
--------------------------------------------------------------------------------
/psql-extras/psql-simple-beam/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/psql-extras/psql-simple-beam/psql-simple-beam.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: psql-simple-beam
3 | version: 0.1.0.0
4 | synopsis: A beam instance for Psql
5 | homepage: https://github.com/obsidiansystems/rhyolite
6 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
7 | license: BSD-3-Clause
8 | license-file: LICENSE
9 | author: Obsidian Systems LLC
10 | maintainer: maintainer@obsidian.systems
11 | copyright: 2021 Obsidian Systems LLC
12 | category: Database
13 | extra-source-files: CHANGELOG.md
14 |
15 | library
16 | exposed-modules: Database.PostgreSQL.Simple.Beam
17 | build-depends:
18 | , base
19 | , beam-core
20 | , beam-postgres
21 | , postgresql-simple
22 | , psql-simple-class
23 |
24 | hs-source-dirs: src
25 | default-language: Haskell2010
26 | ghc-options: -Wall
27 |
--------------------------------------------------------------------------------
/psql-extras/psql-simple-beam/src/Database/PostgreSQL/Simple/Beam.hs:
--------------------------------------------------------------------------------
1 | {-# options_ghc -fno-warn-orphans #-}
2 | module Database.PostgreSQL.Simple.Beam where
3 |
4 | import Database.PostgreSQL.Simple.Class
5 | import qualified Database.PostgreSQL.Simple as P
6 | import Database.Beam.Postgres
7 |
8 | instance Psql Pg where
9 | askConn = liftIOWithHandle pure
10 | execute a b = liftIOWithHandle $ \c -> P.execute c a b
11 | execute_ a = liftIOWithHandle $ \c -> P.execute_ c a
12 | executeMany a b = liftIOWithHandle $ \c -> P.executeMany c a b
13 | query a b = liftIOWithHandle $ \c -> P.query c a b
14 | query_ a = liftIOWithHandle $ \c -> P.query_ c a
15 | queryWith foo bar baz = liftIOWithHandle $ \c -> P.queryWith foo c bar baz
16 | queryWith_ foo bar = liftIOWithHandle $ \c -> P.queryWith_ foo c bar
17 | formatQuery a b = liftIOWithHandle $ \c -> P.formatQuery c a b
18 | returning a b = liftIOWithHandle $ \c -> P.returning c a b
19 |
--------------------------------------------------------------------------------
/psql-extras/psql-simple-class/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | # Revision history for psql-simple-class
2 |
3 | ## 0.1.0.0
4 |
5 | * Create class Psql with various instances
6 |
--------------------------------------------------------------------------------
/psql-extras/psql-simple-class/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/psql-extras/psql-simple-class/psql-simple-class.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: psql-simple-class
3 | version: 0.1.0.0
4 | synopsis: A typeclass for postgresql-simple
5 | description:
6 | Typeclass and instances for database queries using postgresql-simple
7 |
8 | homepage: https://github.com/obsidiansystems/rhyolite
9 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
10 | license: BSD-3-Clause
11 | license-file: LICENSE
12 | author: Obsidian Systems LLC
13 | maintainer: maintainer@obsidian.systems
14 | copyright: 2021 Obsidian Systems LLC
15 | category: Database
16 | extra-source-files: CHANGELOG.md
17 |
18 | library
19 | exposed-modules: Database.PostgreSQL.Simple.Class
20 | build-depends:
21 | , base
22 | , bytestring
23 | , io-streams
24 | , mtl
25 | , postgresql-lo-stream
26 | , postgresql-simple
27 | , postgresql-simple-interpolate
28 | , template-haskell
29 | , transformers
30 |
31 | hs-source-dirs: src
32 | default-language: Haskell2010
33 | ghc-options: -Wall
34 |
--------------------------------------------------------------------------------
/release.nix:
--------------------------------------------------------------------------------
1 | {
2 | self-args ? {
3 | config.android_sdk.accept_license = true;
4 | }
5 | , local-self ? import ./. self-args
6 | , supportedSystems ? [ "x86_64-linux" "x86_64-darwin" ]
7 | }:
8 | let
9 | inherit (local-self) reflex-platform;
10 | inherit (local-self.nixpkgs) lib;
11 |
12 | perPlatform = lib.genAttrs supportedSystems (system: let
13 | self = import ./. (self-args // { inherit system; });
14 | reflex-platform = self.reflex-platform;
15 | cachePackages =
16 | (builtins.attrValues (self.rhyolitePackages self.obelisk))
17 | ++ [
18 | self.proj.ghcjs.rhyolite-frontend
19 | (import ./. {}).proj.ghc.rhyolite-test-suite
20 | ];
21 | in {
22 | cache = reflex-platform.pinBuildInputs "rhyolite-${system}" cachePackages;
23 | });
24 |
25 | metaCache = reflex-platform.pinBuildInputs "rhyolite-everywhere"
26 | (map (a: a.cache) (builtins.attrValues perPlatform));
27 |
28 | in perPlatform // {
29 | inherit metaCache;
30 | }
31 |
--------------------------------------------------------------------------------
/semimap/semimap.cabal:
--------------------------------------------------------------------------------
1 | name: semimap
2 | version: 0.1
3 | synopsis: SemiMap and SemiSet
4 | license: BSD3
5 | author: Obsidian Systems LLC
6 | maintainer: maintainer@obsidian.systems
7 | stability: Experimental
8 | category: Web
9 | build-type: Simple
10 | cabal-version: >=1.2
11 | description: This package defines the concepts of SemiMap and SemiSet.
12 |
13 | library
14 | hs-source-dirs: src
15 | build-depends:
16 | aeson
17 | , base
18 | , containers
19 | , lens
20 | , monoidal-containers
21 | , reflex
22 |
23 | exposed-modules: Rhyolite.SemiMap
24 | other-extensions: TemplateHaskell
25 | ghc-options:
26 | -Wall -fno-warn-unused-do-bind -fwarn-tabs -funbox-strict-fields
27 | -O2 -fprof-auto-calls
28 |
--------------------------------------------------------------------------------
/semimap/src/Rhyolite/SemiMap.hs:
--------------------------------------------------------------------------------
1 | -- | Definition, utilities and instances for 'SemiMap' and 'SemiSet'.
2 |
3 | {-# Language DeriveFoldable #-}
4 | {-# Language DeriveFunctor #-}
5 | {-# Language DeriveGeneric #-}
6 | {-# Language LambdaCase #-}
7 |
8 | module Rhyolite.SemiMap where
9 |
10 | import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey)
11 | import Data.Coerce (coerce)
12 | import Data.Map.Monoidal as Map
13 | import Data.Maybe (isJust)
14 | import Data.Semigroup (First(..))
15 | import Data.Set (Set)
16 | import qualified Data.Set as Set
17 | import GHC.Generics (Generic)
18 |
19 | -- | A SemiMap is a structure built on top on the 'MonoidalMap' that lets you
20 | -- distinguish two semantic meanings of the monoidal map:
21 | data SemiMap k v
22 | = SemiMap_Complete (MonoidalMap k v)
23 | -- ^ The MonoidalMap contains all the information that I want to express.
24 | | SemiMap_Partial (MonoidalMap k (First (Maybe v)))
25 | -- ^ I'm only expressing a patch for some information that I already possess.
26 | deriving (Show, Read, Eq, Ord, Foldable, Functor, Generic)
27 |
28 | isComplete :: SemiMap k v -> Bool
29 | isComplete = isJust . getComplete
30 |
31 | getComplete :: SemiMap k v -> Maybe (MonoidalMap k v)
32 | getComplete = \case
33 | SemiMap_Complete m -> Just m
34 | SemiMap_Partial _ -> Nothing
35 |
36 | knownKeysSet :: SemiMap k v -> Set k
37 | knownKeysSet = \case
38 | SemiMap_Complete x -> Map.keysSet x
39 | SemiMap_Partial x -> Map.keysSet $ Map.mapMaybe getFirst x
40 |
41 | knownKeys :: SemiMap k v -> [k]
42 | knownKeys = Set.toList . knownKeysSet
43 |
44 | knownSubMap :: SemiMap k v -> MonoidalMap k v
45 | knownSubMap = \case
46 | SemiMap_Complete m -> m
47 | SemiMap_Partial m -> Map.mapMaybe getFirst m
48 |
49 | instance (Ord k) => Monoid (SemiMap k v) where
50 | mempty = SemiMap_Partial mempty
51 |
52 | instance (Ord k) => Semigroup (SemiMap k v) where
53 | new <> old = case new of
54 | SemiMap_Complete _ -> new
55 | SemiMap_Partial p -> case old of
56 | SemiMap_Partial oldp -> SemiMap_Partial $ p <> oldp
57 | SemiMap_Complete oldc -> SemiMap_Complete $ applyMap (coerce p) (coerce oldc)
58 | where
59 | applyMap :: Ord k => MonoidalMap k (Maybe v) -> MonoidalMap k v -> MonoidalMap k v
60 | applyMap patch old' = Map.unionWith const insertions (old' `Map.difference` deletions)
61 | where (deletions, insertions) = Map.mapEither maybeToEither patch
62 | maybeToEither = \case
63 | Nothing -> Left ()
64 | Just r -> Right r
65 |
66 | instance (ToJSON k, ToJSON v, ToJSONKey k) => ToJSON (SemiMap k v)
67 | instance (Ord k, FromJSON k, FromJSON v, FromJSONKey k) => FromJSON (SemiMap k v)
68 |
69 | -- | With a SemiSet, you can express that you have a complete set of elements,
70 | -- or a patch that modifies another collection.
71 | type SemiSet k = SemiMap k ()
72 |
73 | fromKnown :: Set k -> SemiSet k
74 | fromKnown = SemiMap_Partial . Map.fromSet (\_ -> First $ Just ())
75 |
76 | fromKnownAbsent :: Set k -> SemiMap k ()
77 | fromKnownAbsent = SemiMap_Partial . Map.fromSet (\_ -> First Nothing)
78 |
79 | fromKnownComplete :: Set k -> SemiMap k ()
80 | fromKnownComplete = SemiMap_Complete . Map.fromSet (\_ -> ())
81 |
82 | -- | A SemiMap that knows whether a particular item is present, but doesn't know
83 | -- anything about the presence or absence of other items.
84 | singleKnownPresence
85 | :: a -- ^ The item
86 | -> Bool -- ^ Whether it is present
87 | -> SemiSet a
88 | singleKnownPresence a b = f $ Set.singleton a
89 | where f = case b of
90 | False -> fromKnownAbsent
91 | True -> fromKnown
92 |
--------------------------------------------------------------------------------
/signed-data/signed-data-clientsession/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/signed-data/signed-data-clientsession/signed-data-clientsession.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: signed-data-clientsession
3 | version: 0.1.0.0
4 | synopsis: Sign data using a client session key
5 | description:
6 | Instance for MonadSign using Web.ClientSession as the key source
7 |
8 | homepage: https://github.com/obsidiansystems/rhyolite
9 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
10 | license: BSD-3-Clause
11 | license-file: LICENSE
12 | author: Obsidian Systems LLC
13 | maintainer: maintainer@obsidian.systems
14 | copyright: 2021 Obsidian Systems LLC
15 | category: Data
16 |
17 | library
18 | exposed-modules: Data.Signed.ClientSession
19 | build-depends:
20 | , aeson
21 | , base
22 | , bytestring
23 | , clientsession
24 | , monad-control
25 | , monad-logger
26 | , mtl
27 | , signed-data
28 | , text
29 | , transformers
30 | , transformers-base
31 |
32 | hs-source-dirs: src
33 | default-language: Haskell2010
34 |
--------------------------------------------------------------------------------
/signed-data/signed-data-clientsession/src/Data/Signed/ClientSession.hs:
--------------------------------------------------------------------------------
1 | -- | Functions to encrypt data using "Web.ClientSession"
2 |
3 |
4 | {-# Language FlexibleContexts #-}
5 | {-# Language FlexibleInstances #-}
6 | {-# Language GeneralizedNewtypeDeriving #-}
7 | {-# Language MultiParamTypeClasses #-}
8 | {-# Language ScopedTypeVariables #-}
9 | {-# Language TemplateHaskell #-}
10 | {-# Language TypeApplications #-}
11 | {-# Language TypeFamilies #-}
12 | {-# Language UndecidableInstances #-}
13 |
14 | {-# OPTIONS_GHC -fno-warn-orphans #-}
15 |
16 | module Data.Signed.ClientSession
17 | ( module Data.Signed.ClientSession
18 | , CS.Key
19 | , CS.getKey
20 | ) where
21 |
22 | import Control.Monad (guard)
23 | import Control.Monad.Base
24 | import Control.Monad.IO.Class (MonadIO, liftIO)
25 | import Control.Monad.Logger
26 | import Control.Monad.Reader
27 | import Control.Monad.Trans.Control
28 | import Data.Aeson (FromJSON, ToJSON, encode, decodeStrict')
29 | import qualified Data.ByteString.Lazy as LBS
30 | import Data.Proxy (Proxy(..))
31 | import Data.Text.Encoding (decodeUtf8, encodeUtf8)
32 | import Data.Typeable (Typeable, typeRep)
33 | import qualified Web.ClientSession as CS
34 | import Data.Signed (MonadSign(..), Signed(..))
35 |
36 | signWithKey :: (Typeable a, ToJSON a, MonadIO m) => CS.Key -> a -> m (Signed a)
37 | signWithKey k (v :: a) =
38 | liftIO $ fmap (Signed . decodeUtf8) $ CS.encryptIO k $ LBS.toStrict $ encode (show $ typeRep (Proxy @a), v)
39 |
40 | readSignedWithKey :: (Typeable a, FromJSON a) => CS.Key -> Signed a -> Maybe a
41 | readSignedWithKey k s = do
42 | tvJson <- CS.decrypt k $ encodeUtf8 $ unSigned s
43 | (t, v :: b) <- decodeStrict' tvJson
44 | guard $ t == show (typeRep $ Proxy @b)
45 | return v
46 |
47 | -- We need the Typeable here because otherwise two 'Signed's whose contents encode the same way will be interchangeable
48 | sign :: (MonadSign m, SigningKey m ~ CS.Key, MonadIO m, Typeable a, ToJSON a) => a -> m (Signed a)
49 | sign a = do
50 | k <- askSigningKey
51 | signWithKey k a
52 |
53 | readSigned :: (MonadSign m, SigningKey m ~ CS.Key, Typeable a, FromJSON a) => Signed a -> m (Maybe a)
54 | readSigned s = do
55 | k <- askSigningKey
56 | pure $ readSignedWithKey k s
57 |
58 | newtype SignT m a = SignT { unSignT :: ReaderT CS.Key m a }
59 | deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadLogger)
60 |
61 | runSignT :: SignT m a -> CS.Key -> m a
62 | runSignT (SignT a) = runReaderT a
63 |
64 | instance MonadBase b m => MonadBase b (SignT m) where
65 | liftBase = SignT . liftBase
66 |
67 | instance MonadTransControl SignT where
68 | type StT SignT a = StT (ReaderT CS.Key) a
69 | liftWith f = SignT $ liftWith $ \g -> f $ g . unSignT
70 | restoreT a = SignT $ restoreT a
71 |
72 | instance (MonadIO m, MonadBaseControl IO m) => MonadBaseControl IO (SignT m) where
73 | type StM (SignT m) a = StM (ReaderT CS.Key m) a
74 | liftBaseWith f = SignT $ liftBaseWith $ \g -> f $ g . unSignT
75 | restoreM a = SignT $ restoreM a
76 |
77 | instance Monad m => MonadSign (SignT m) where
78 | type SigningKey (SignT m) = CS.Key
79 | askSigningKey = SignT ask
80 |
81 | -- Orphans
82 | instance MonadSign m => MonadSign (NoLoggingT m) where
83 | type SigningKey (NoLoggingT m) = SigningKey m
84 |
--------------------------------------------------------------------------------
/signed-data/signed-data/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | # Revision history for signed-data
2 |
3 | ## 0.1.0.0 -- YYYY-mm-dd
4 |
5 | * First version. Released on an unsuspecting world.
6 |
--------------------------------------------------------------------------------
/signed-data/signed-data/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/signed-data/signed-data/signed-data.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: signed-data
3 | version: 0.1.0.0
4 | synopsis: Types for signed data
5 | description:
6 | Types and a monad for working single-key encrypted data. Useful for, e.g., signing cookies.
7 |
8 | homepage: https://github.com/obsidiansystems/rhyolite
9 | bug-reports: https://github.com/obsidiansystems/rhyolite/issues
10 | license: BSD-3-Clause
11 | license-file: LICENSE
12 | author: Obsidian Systems LLC
13 | maintainer: maintainer@obsidian.systems
14 | copyright: 2021 Obsidian Systems LLC
15 | category: Data
16 | extra-source-files: CHANGELOG.md
17 |
18 | library
19 | exposed-modules: Data.Signed
20 | build-depends:
21 | , aeson
22 | , base
23 | , mtl
24 | , text
25 | , transformers
26 |
27 | hs-source-dirs: src
28 | default-language: Haskell2010
29 |
--------------------------------------------------------------------------------
/signed-data/signed-data/src/Data/Signed.hs:
--------------------------------------------------------------------------------
1 | -- | Infrastructure for signing data, which you would use, e.g. when signing cookies.
2 |
3 | {-# Language DefaultSignatures #-}
4 | {-# Language FlexibleContexts #-}
5 | {-# Language FlexibleInstances #-}
6 | {-# Language GADTs #-}
7 | {-# Language GeneralizedNewtypeDeriving #-}
8 | {-# Language ScopedTypeVariables #-}
9 | {-# Language TypeFamilies #-}
10 | {-# Language UndecidableInstances #-}
11 |
12 | module Data.Signed where
13 |
14 | import Data.Text (Text)
15 | import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)
16 | import Control.Monad.Reader (ReaderT)
17 | import Control.Monad.State (StateT)
18 | import Control.Monad.Trans (MonadTrans (lift))
19 | import Control.Monad.Trans.Except (ExceptT)
20 | import Control.Monad.Trans.Maybe (MaybeT)
21 | import qualified Control.Monad.State.Strict as Strict
22 |
23 | -- | A wrapper around 'Text' that contains the signed payload.
24 | newtype Signed a = Signed { unSigned :: Text }
25 | deriving (Show, Read, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
26 |
27 | class Monad m => MonadSign m where
28 | type SigningKey m
29 | askSigningKey :: m (SigningKey m)
30 | default askSigningKey
31 | :: (m ~ t m', SigningKey (t m') ~ SigningKey m', MonadTrans t, MonadSign m', Monad m')
32 | => m (SigningKey m)
33 | askSigningKey = lift askSigningKey
34 |
35 | instance MonadSign m => MonadSign (ReaderT r m) where
36 | type SigningKey (ReaderT r m) = SigningKey m
37 |
38 | instance MonadSign m => MonadSign (StateT s m) where
39 | type SigningKey (StateT s m) = SigningKey m
40 |
41 | instance MonadSign m => MonadSign (Strict.StateT s m) where
42 | type SigningKey (Strict.StateT s m) = SigningKey m
43 |
44 | instance MonadSign m => MonadSign (MaybeT m) where
45 | type SigningKey (MaybeT m) = SigningKey m
46 |
47 | instance MonadSign m => MonadSign (ExceptT e m) where
48 | type SigningKey (ExceptT e m) = SigningKey m
49 |
--------------------------------------------------------------------------------
/test/rhyolite-test-suite.cabal:
--------------------------------------------------------------------------------
1 | name: rhyolite-test-suite
2 | version: 0.1
3 | synopsis: Tests for rhyolite
4 | license: BSD3
5 | author: Obsidian Systems LLC
6 | maintainer: maintainer@obsidian.systems
7 | stability: Experimental
8 | category: Web
9 | build-type: Simple
10 | cabal-version: >=1.2
11 |
12 | executable rhyolite-test-suite
13 | hs-source-dirs: src-bin
14 | main-is: test.hs
15 | build-depends:
16 | base
17 | , bytestring-aeson-orphans
18 | , psql-simple-beam
19 | , psql-simple-class
20 | , rhyolite-account-backend
21 | , rhyolite-account-types
22 | , rhyolite-backend
23 | , rhyolite-beam-task-worker-backend
24 | , rhyolite-common
25 | , rhyolite-email
26 | , rhyolite-frontend
27 | , rhyolite-notify-listen
28 | , rhyolite-notify-listen-beam
29 | , rhyolite-widgets
30 | , semimap
31 | , signed-data
32 | , signed-data-clientsession
33 |
34 | ghc-options:
35 | -threaded -Wall -fno-warn-unused-do-bind -fwarn-tabs
36 | -funbox-strict-fields -O2 -fprof-auto-calls -rtsopts
37 |
--------------------------------------------------------------------------------
/test/src-bin/test.hs:
--------------------------------------------------------------------------------
1 | {-# Language PackageImports #-}
2 | {-# OPTIONS_GHC -Wno-unused-imports #-}
3 | module Main where
4 |
5 | --common
6 | import Rhyolite.App
7 | -- backend
8 | import Rhyolite.Backend.App
9 | -- frontend
10 | import Rhyolite.Frontend.App
11 | -- semimap
12 | import Rhyolite.SemiMap
13 | -- rhyolite-widgets
14 | import qualified Reflex.Dom.Widget.ExtensibleList
15 |
16 | -- psql-extras
17 | import qualified Database.PostgreSQL.Simple.Class
18 | import qualified Database.PostgreSQL.Simple.Beam
19 |
20 | -- notify-listen
21 | import qualified Rhyolite.DB.NotifyListen
22 | import qualified Rhyolite.DB.NotifyListen.Beam
23 |
24 | -- email
25 | import qualified Rhyolite.Email
26 |
27 | -- signed-data
28 | import qualified Data.Signed
29 | -- signed-data-clientsession
30 | import qualified Data.Signed.ClientSession
31 |
32 | -- accounts
33 | import qualified "rhyolite-account-types" Rhyolite.Account
34 | import qualified "rhyolite-account-backend" Rhyolite.Backend.Account
35 |
36 | main :: IO ()
37 | main = putStrLn "rhyolite submodules were successfully built"
38 |
--------------------------------------------------------------------------------
/widgets/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | # Revision history for rhyolite-widgets
2 |
3 | ## 0.1.0.0 -- YYYY-mm-dd
4 |
5 | * First version. Released on an unsuspecting world.
6 |
--------------------------------------------------------------------------------
/widgets/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2021, Obsidian Systems LLC
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Obsidian Systems LLC nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/widgets/rhyolite-widgets.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 2.4
2 | name: rhyolite-widgets
3 | version: 0.1.0.0
4 | synopsis: Various widgets and controls
5 | description:
6 | Reusable, fairly general widgets and controls for reflex-dom UIs
7 |
8 | homepage: https://github.com/obsidiansystems/rhyolite
9 | bug-reports: https://github.com/obsidiansystems/rhyolite
10 | license: BSD-3-Clause
11 | license-file: LICENSE
12 | author: Obsidian Systems LLC
13 | maintainer: maintainer@obsidian.systems
14 | copyright: Obsidian Systems LLC
15 | category: UI
16 |
17 | library
18 | exposed-modules:
19 | Reflex.Dom.Widget.ExtensibleList
20 | Reflex.Dom.Widget.Form
21 |
22 | build-depends:
23 | , base
24 | , containers
25 | , either
26 | , ghcjs-dom
27 | , jsaddle
28 | , lens
29 | , mtl
30 | , obelisk-executable-config-lookup
31 | , obelisk-route
32 | , primitive
33 | , ref-tf
34 | , reflex
35 | , reflex-dom-core
36 | , text
37 | , transformers
38 | , validation
39 |
40 | hs-source-dirs: src
41 | default-language: Haskell2010
42 |
--------------------------------------------------------------------------------
/widgets/src/Reflex/Dom/Widget/ExtensibleList.hs:
--------------------------------------------------------------------------------
1 | -- | A couple utilities to deal with list of items in which each item can return
2 | -- controls for insertion before and after, and deletion. See 'ListEdit' and
3 | -- 'extensibleListWidget'.
4 |
5 | {-# Language LambdaCase #-}
6 | {-# Language OverloadedStrings #-}
7 | {-# Language RecursiveDo #-}
8 | {-# Language ScopedTypeVariables #-}
9 | module Reflex.Dom.Widget.ExtensibleList where
10 |
11 | import Control.Monad.Fix
12 | import Data.Either.Combinators (rightToMaybe)
13 | import Data.Map (Map)
14 | import qualified Data.Map as Map
15 | import Data.Text (Text)
16 | import Reflex.Dom.Core hiding (Delete)
17 |
18 | data ListEdit = ListEdit_InsertBefore | ListEdit_Delete | ListEdit_InsertAfter
19 | deriving (Eq, Ord, Show, Read)
20 |
21 | extensibleListWidget
22 | :: forall t m a b. (DomBuilder t m, MonadHold t m, MonadFix m)
23 | => Int -- ^ Minimum number of entries (be careful: if this is 0, the entire list is allowed to vanish)
24 | -> a -- ^ Initial entry for newly inserted items
25 | -> [a] -- ^ Initial sequence of entries
26 | -> Event t () -- ^ Add an item at the end of the list
27 | -> (Dynamic t Int -> a -> m (Event t ListEdit, Dynamic t b))
28 | -- ^ Widget for a single item which is expected to include
29 | -- the list editing controls and pass through the resulting events.
30 | -> m (Dynamic t [b])
31 | extensibleListWidget n x0 xs0 addAtEnd itemWidget = extensibleListWidgetWithSize n x0 xs0 addAtEnd (\d -> itemWidget (fst <$> d))
32 |
33 | -- | Like `extensibleListWidget`, but the items know the current size of the whole list, as well as their position.
34 | extensibleListWidgetWithSize
35 | :: forall t m a b. (DomBuilder t m, MonadHold t m, MonadFix m)
36 | => Int -- ^ Minimum number of entries (be careful: if this is 0, the entire list is allowed to vanish)
37 | -> a -- ^ Initial entry for newly inserted items
38 | -> [a] -- ^ Initial sequence of entries
39 | -> Event t () -- ^ Add an item at the end of the list
40 | -> (Dynamic t (Int, Int) -> a -> m (Event t ListEdit, Dynamic t b))
41 | -- ^ Widget for a single item which is expected to include
42 | -- the list editing controls and pass through the resulting events.
43 | -- First argument is (item position, total number of items).
44 | -> m (Dynamic t [b])
45 | extensibleListWidgetWithSize n x0 xs0 addAtEnd itemWidget = do
46 | let genIndex :: Map Rational a -> Map Rational a -> Rational
47 | genIndex us vs =
48 | case (Map.maxViewWithKey us, Map.minViewWithKey vs) of
49 | (Nothing , Nothing ) -> 0
50 | (Nothing , Just ((v, _), _)) -> v - 1
51 | (Just ((u, _), _), Nothing ) -> u + 1
52 | (Just ((u, _), _), Just ((v, _), _)) -> (u + v) / 2
53 | handleChange :: (Rational, ListEdit) -> Map Rational a -> Map Rational (Maybe a)
54 | handleChange (k, ListEdit_InsertBefore) xs =
55 | let (us, x, vs) = Map.splitLookup k xs
56 | vs' = Map.alter (const x) k vs
57 | i = genIndex us vs'
58 | in Map.singleton i (Just x0)
59 | handleChange (k, ListEdit_Delete) xs =
60 | if Map.size xs > n
61 | then Map.singleton k Nothing
62 | else Map.singleton k (Just x0)
63 | handleChange (k, ListEdit_InsertAfter) xs =
64 | let (us, x, vs) = Map.splitLookup k xs
65 | us' = Map.alter (const x) k us
66 | i = genIndex us' vs
67 | in Map.singleton i (Just x0)
68 | map0 :: Map Rational (Maybe a) = Map.fromList . zip [0..] $ fmap Just xs0
69 | rec let attachList xs x = case x of
70 | Nothing -> case Map.maxViewWithKey xs of
71 | Nothing -> handleChange (0, ListEdit_InsertAfter) xs
72 | Just ((k, _), _) -> handleChange (k, ListEdit_InsertAfter) xs
73 | Just x' -> handleChange x' xs
74 | updateEvent :: Event t (Map Rational (Maybe a)) = attachWith attachList (current listMapD) $ leftmost
75 | [ Just <$> changeMapE
76 | , Nothing <$ addAtEnd
77 | ]
78 | listMapD :: Dynamic t (Map Rational a) <- fmap (Map.mapMaybe id) <$> foldDyn (\e m -> Map.union e m) map0 updateEvent
79 | let ixMapD :: Dynamic t (Map Rational Int) = fmap (Map.fromList . (`zip` [0::Int ..]) . Map.keys) listMapD
80 | resultMapD <- listHoldWithKey (Map.mapMaybe id map0) updateEvent $ \k v -> do
81 | let ix = fmap (Map.findWithDefault (-1) k) ixMapD
82 | -- TODO, maybe: figure out why this Map lookup is too strict.
83 | -- Deleting an item causes a failed lookup, however, I'm not sure it really matters.
84 | itemWidget ((,) <$> ix <*> fmap length listMapD) v
85 | let changeMapE = switch . current $ fmap (leftmost . fmap (\(k, v) -> fmap ((,) k) v) . Map.toList . fmap fst) resultMapD
86 | valuesMapD = joinDynThroughMap $ fmap (fmap snd) resultMapD
87 | valuesD = fmap Map.elems valuesMapD
88 | return valuesD
89 |
--------------------------------------------------------------------------------