├── README.md
├── client
├── .env.development
├── .gitignore
├── .proxyrc.js
├── .psc-ide-port
├── .vscode
│ └── settings.json
├── craco.config.js
├── dev
│ ├── index.html
│ └── index.js
├── package.json
├── packages.dhall
├── spago.dhall
├── src
│ ├── Data
│ │ ├── Argonaut
│ │ │ └── JSONDateTime.purs
│ │ └── UUID
│ │ │ └── Argonaut.purs
│ ├── Foreign
│ │ ├── Toast.js
│ │ └── Toast.purs
│ ├── GenTypesDemo
│ │ ├── API
│ │ │ ├── Auth.purs
│ │ │ ├── Call.purs
│ │ │ ├── Error.purs
│ │ │ └── Types.purs
│ │ ├── Aggregate
│ │ │ ├── Class.purs
│ │ │ └── Events.purs
│ │ ├── AppM.purs
│ │ ├── Capability
│ │ │ ├── Global.purs
│ │ │ ├── Halo.purs
│ │ │ ├── Log.purs
│ │ │ ├── Now.purs
│ │ │ ├── Routing.purs
│ │ │ └── Users.purs
│ │ ├── Component
│ │ │ ├── GlobalContext.purs
│ │ │ ├── NewUserRow.purs
│ │ │ └── Routing.purs
│ │ ├── Config.js
│ │ ├── Config.purs
│ │ ├── Data
│ │ │ ├── Log.purs
│ │ │ └── Route.purs
│ │ ├── Page
│ │ │ └── Home.purs
│ │ ├── Root.purs
│ │ └── Utilities
│ │ │ └── Email.purs
│ ├── Main.purs
│ ├── ServerAPI.purs
│ ├── input.css
│ └── styles.css
├── tailwind.config.js
├── test
│ └── Main.purs
├── theme.js
└── yarn.lock
├── demo.gif
└── server
├── .gitignore
├── ChangeLog.md
├── LICENSE
├── Setup.hs
├── app
└── Main.hs
├── codegen.sh
├── codegen
└── Main.hs
├── gentypes-server.cabal
├── hie.yaml
├── package.yaml
├── run.sh
├── src
└── GenTypesDemo
│ ├── API
│ ├── Auth.hs
│ ├── CodeGen.hs
│ ├── Definition.hs
│ ├── DomainError.hs
│ ├── ManageUsers.hs
│ ├── Types.hs
│ └── Types
│ │ └── NotEmptyText.hs
│ └── Run.hs
├── stack.yaml
├── stack.yaml.lock
└── test
└── Spec.hs
/README.md:
--------------------------------------------------------------------------------
1 | # Haskell Servant + PureScript React with Code Generation :heart:
2 |
3 | 
4 |
5 | A demo application showcasing a Haskell Servant server + a PureScript React (`react-basic-hooks` and `react-halo`) client with code generation.
6 |
7 | Running `/server/codegen.sh` will generate the API types together with a client, visible in [Types.purs](./client/src/GenTypesDemo/API/Types.purs) and [ServerAPI.purs](./client/src/ServerAPI.purs).
8 |
9 | To achieve this the project uses [purescript-bridge](https://github.com/input-output-hk/purescript-bridge) and [servant-purescript](https://github.com/input-output-hk/servant-purescript).
10 |
11 | For the application logic this project uses [effectful](https://hackage.haskell.org/package/effectful), but there's an `mtl` version on the `mtl` branch.
12 |
13 | # Suggested workflow
14 |
15 | This setup enables an extremely productive workflow as it takes very little effort to change things while being confident your client to server communication works properly.
16 |
17 | ## Add your types and endpoint
18 |
19 | ```haskell
20 | -- API/Types.hs
21 | ...
22 |
23 | data User = User
24 | { id :: UserId,
25 | info :: UserData
26 | }
27 | deriving (Generic)
28 | deriving anyclass (ToJSON, FromJSON)
29 |
30 | data UserData = UserData
31 | { email :: Email,
32 | username :: Username,
33 | created :: CreatedAt
34 | }
35 | deriving (Generic)
36 | deriving anyclass (ToJSON, FromJSON)
37 |
38 | ... other types omitted for brevity
39 | ```
40 |
41 | ```haskell
42 | -- API/Definition.hs
43 | type UsersApi =
44 | "users" :> Get '[JSON] [User]
45 | ```
46 |
47 | ## Add the types to `myTypes` in `API/CodeGen.hs`
48 |
49 | ```haskell
50 | -- API/CodeGen.hs
51 | myTypes :: [SumType 'Haskell]
52 | myTypes =
53 | [
54 | genericShow $ equal $ argonaut $ mkSumType @User,
55 | genericShow $ equal $ argonaut $ mkSumType @UserData,
56 | ... other types omitted for brevity
57 | ]
58 | ```
59 |
60 | ## Run `/server/codegen.sh`.
61 |
62 | Your types will appear on the client side.
63 |
64 | ```purescript
65 | -- API/Types.purs
66 | newtype User = User
67 | { id :: UserId
68 | , info :: UserData
69 | }
70 |
71 | instance Show User where
72 | show a = genericShow a
73 |
74 | derive instance Eq User
75 |
76 | instance EncodeJson User where
77 | encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record
78 | { id: E.value :: _ UserId
79 | , info: E.value :: _ UserData
80 | })
81 |
82 | instance DecodeJson User where
83 | decodeJson = defer \_ -> D.decode $ (User <$> D.record "User"
84 | { id: D.value :: _ UserId
85 | , info: D.value :: _ UserData
86 | })
87 |
88 | derive instance Generic User _
89 |
90 | derive instance Newtype User _
91 | ```
92 |
93 | ```purescript
94 | -- ServerAPI.purs
95 | getUsers ::
96 | forall m.
97 | MonadAjax Api m =>
98 | m (Either (AjaxError JsonDecodeError Json) (Array User))
99 | getUsers =
100 | request Api req
101 | where
102 | req = { method, uri, headers, content, encode, decode }
103 | method = Left GET
104 | uri = RelativeRef relativePart query Nothing
105 | headers = catMaybes
106 | [
107 | ]
108 | content = Nothing
109 | encode = E.encode encoder
110 | decode = D.decode decoder
111 | encoder = E.null
112 | decoder = D.value
113 | relativePart = RelativePartNoAuth $ Just
114 | [ "users"
115 | ]
116 | query = Nothing
117 | ```
118 |
119 | ## Link the newly generated API operation to your monad stack
120 |
121 | ```purescript
122 | -- Capability/Users.purs
123 | class Monad m <= MonadUsers m where
124 | listUsers :: m (Either APIError (Array User))
125 |
126 | -- AppM.purs
127 | instance monadUsersAppM :: MonadUsers AppM where
128 | listUsers = callApi ServerAPI.getUsers
129 | ```
130 |
131 | You can now use `listUsers` in your application code without duplicating any types or write any custom deserialization logic!
132 |
133 | # Known issues/quirks
134 |
135 | I haven't yet found any dealbreakers, and most of these issues can be fixed with a PR, but still.
136 |
137 | ## Endpoints using `NoContent`
138 |
139 | For some reason if you use `NoContent` instead of `()` on your Servant routes the API call will result in a deserialization error on the PureScript side.
140 |
141 | ## `Required` `QueryParams` don't become required
142 |
143 | If you're using any `QueryParams` with `'[Required]`, the PureScript code generation will not pick it up and you'll still have them as optional in `ServerAPI.purs`.
144 |
145 | ## Haskell `newtype`s with a named field will not deserialize properly
146 |
147 | For example if you have something like:
148 |
149 | ```haskell
150 | newtype Username = Username { unUsername :: Text }
151 | ```
152 |
153 | this will fail to deserialize. A usable workaround is to define `unUsername` separately like so:
154 |
155 | ```haskell
156 | newtype Username = Username Text
157 |
158 | unUsername :: Username -> Text
159 | unUsername = coerce
160 | ```
161 |
162 | # What's not shown (yet)
163 |
164 | * Handling polymorphic types
165 |
166 | # Running it locally
167 |
168 | ## server
169 |
170 | In `./server` (assuming you have `stack` installed)
171 |
172 | ```
173 | ./run.sh
174 | ```
175 |
176 | ## client
177 |
178 | In `./client` (assuming you have `yarn` installed)
179 |
180 | ```
181 | yarn install
182 | yarn run start
183 | ```
184 |
--------------------------------------------------------------------------------
/client/.env.development:
--------------------------------------------------------------------------------
1 | DEPLOYMENT_URL=http://localhost:1234
2 | API_URL=localhost:3005
--------------------------------------------------------------------------------
/client/.gitignore:
--------------------------------------------------------------------------------
1 | # See https://help.github.com/articles/ignoring-files/ for more about ignoring files.
2 |
3 | # dependencies
4 | /node_modules
5 | /.pnp
6 | .pnp.js
7 |
8 | # testing
9 | /coverage
10 |
11 | # production
12 | /build
13 | /dist
14 | dce-output
15 | .parcel-cache
16 |
17 | # misc
18 | .DS_Store
19 | .env.local
20 | .env.development.local
21 | .env.test.local
22 | .env.production.local
23 |
24 | npm-debug.log*
25 | yarn-debug.log*
26 | yarn-error.log*
27 |
28 | /output
29 | .spago
30 | .parcel-cache
31 |
--------------------------------------------------------------------------------
/client/.proxyrc.js:
--------------------------------------------------------------------------------
1 | const serveStatic = require('serve-static')
2 |
3 | module.exports = function (app) {
4 | // Use static middleware
5 | app.use(serveStatic('static'))
6 | }
--------------------------------------------------------------------------------
/client/.psc-ide-port:
--------------------------------------------------------------------------------
1 | 15476
--------------------------------------------------------------------------------
/client/.vscode/settings.json:
--------------------------------------------------------------------------------
1 | {
2 | "search.exclude": {
3 | "**/.spago": true,
4 | "**/output": true
5 | }
6 | }
--------------------------------------------------------------------------------
/client/craco.config.js:
--------------------------------------------------------------------------------
1 | const cracoPureScriptLoader = require("craco-purescript-loader");
2 |
3 | module.exports = {
4 | plugins: [
5 | {
6 | plugin: cracoPureScriptLoader,
7 | options: {
8 | spago: true,
9 | pscIde: true,
10 | },
11 | },
12 | ],
13 | };
14 |
--------------------------------------------------------------------------------
/client/dev/index.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 | PureScript Code Generation
7 |
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 |
--------------------------------------------------------------------------------
/client/dev/index.js:
--------------------------------------------------------------------------------
1 | import 'react-toastify/dist/ReactToastify.css';
2 |
3 | require('@fontsource/inter');
4 | require("../output/Main/index.js").main();
5 |
--------------------------------------------------------------------------------
/client/package.json:
--------------------------------------------------------------------------------
1 | {
2 | "name": "types-generation",
3 | "version": "0.1.0",
4 | "private": true,
5 | "dependencies": {
6 | "@fontsource/inter": "^4.5.11",
7 | "aos": "^2.3.4",
8 | "dayjs": "^1.10.8",
9 | "react": "^17.0.0",
10 | "react-dom": "^17.0.0",
11 | "react-toastify": "^9.0.5",
12 | "url": "^0.11.0",
13 | "uuid": "^8.3.2",
14 | "web-vitals": "^2.1.4",
15 | "xhr2": "^0.2.1"
16 | },
17 | "scripts": {
18 | "start": "NODE_ENV=development npx spago build && parcel dev/index.html",
19 | "build": "npx spago build",
20 | "bundle": "NODE_ENV=production rm -rf dist && yarn bundle:build && yarn bundle:dce && yarn bundle:parcel && yarn bundle:static",
21 | "bundle:static": "cp -r static/* dist",
22 | "bundle:build": "npx spago build --purs-args '--codegen corefn'",
23 | "bundle:dce": "zephyr -f Main.main",
24 | "bundle:parcel": "parcel build dev/index.html --no-source-maps",
25 | "css": "npx tailwindcss -i ./src/input.css -o ./src/styles.css --watch",
26 | "serve-prod": "npx http-server dist -o -p 1234"
27 | },
28 | "browserslist": {
29 | "production": [
30 | ">0.2%",
31 | "not dead",
32 | "not op_mini all"
33 | ],
34 | "development": [
35 | "last 1 chrome version",
36 | "last 1 firefox version",
37 | "last 1 safari version"
38 | ]
39 | },
40 | "devDependencies": {
41 | "autoprefixer": "^10.4.2",
42 | "buffer": "^6.0.3",
43 | "parcel": "^2.3.2",
44 | "parcel-plugin-static-files-copy": "^2.6.0",
45 | "postcss": "^8.4.6",
46 | "prettier": "2.5.1",
47 | "process": "^0.11.10",
48 | "purescript": "^0.15.7",
49 | "purty": "^7.0.0",
50 | "querystring-es3": "^0.2.1",
51 | "serve-static": "^1.15.0",
52 | "spago": "^0.20.9",
53 | "tailwindcss": "^3.0.23",
54 | "zephyr": "https://github.com/jonasbuntinx/zephyr.git"
55 | }
56 | }
57 |
--------------------------------------------------------------------------------
/client/packages.dhall:
--------------------------------------------------------------------------------
1 | {-
2 | Welcome to your new Dhall package-set!
3 |
4 | Below are instructions for how to edit this file for most use
5 | cases, so that you don't need to know Dhall to use it.
6 |
7 | ## Warning: Don't Move This Top-Level Comment!
8 |
9 | Due to how `dhall format` currently works, this comment's
10 | instructions cannot appear near corresponding sections below
11 | because `dhall format` will delete the comment. However,
12 | it will not delete a top-level comment like this one.
13 |
14 | ## Use Cases
15 |
16 | Most will want to do one or both of these options:
17 | 1. Override/Patch a package's dependency
18 | 2. Add a package not already in the default package set
19 |
20 | This file will continue to work whether you use one or both options.
21 | Instructions for each option are explained below.
22 |
23 | ### Overriding/Patching a package
24 |
25 | Purpose:
26 | - Change a package's dependency to a newer/older release than the
27 | default package set's release
28 | - Use your own modified version of some dependency that may
29 | include new API, changed API, removed API by
30 | using your custom git repo of the library rather than
31 | the package set's repo
32 |
33 | Syntax:
34 | Replace the overrides' "{=}" (an empty record) with the following idea
35 | The "//" or "⫽" means "merge these two records and
36 | when they have the same value, use the one on the right:"
37 | -------------------------------
38 | let overrides =
39 | { packageName =
40 | upstream.packageName // { updateEntity1 = "new value", updateEntity2 = "new value" }
41 | , packageName =
42 | upstream.packageName // { version = "v4.0.0" }
43 | , packageName =
44 | upstream.packageName // { repo = "https://www.example.com/path/to/new/repo.git" }
45 | }
46 | -------------------------------
47 |
48 | Example:
49 | -------------------------------
50 | let overrides =
51 | { halogen =
52 | upstream.halogen // { version = "master" }
53 | , halogen-vdom =
54 | upstream.halogen-vdom // { version = "v4.0.0" }
55 | }
56 | -------------------------------
57 |
58 | ### Additions
59 |
60 | Purpose:
61 | - Add packages that aren't already included in the default package set
62 |
63 | Syntax:
64 | Replace the additions' "{=}" (an empty record) with the following idea:
65 | -------------------------------
66 | let additions =
67 | { package-name =
68 | { dependencies =
69 | [ "dependency1"
70 | , "dependency2"
71 | ]
72 | , repo =
73 | "https://example.com/path/to/git/repo.git"
74 | , version =
75 | "tag ('v4.0.0') or branch ('master')"
76 | }
77 | , package-name =
78 | { dependencies =
79 | [ "dependency1"
80 | , "dependency2"
81 | ]
82 | , repo =
83 | "https://example.com/path/to/git/repo.git"
84 | , version =
85 | "tag ('v4.0.0') or branch ('master')"
86 | }
87 | , etc.
88 | }
89 | -------------------------------
90 |
91 | Example:
92 | -------------------------------
93 | let additions =
94 | { benchotron =
95 | { dependencies =
96 | [ "arrays"
97 | , "exists"
98 | , "profunctor"
99 | , "strings"
100 | , "quickcheck"
101 | , "lcg"
102 | , "transformers"
103 | , "foldable-traversable"
104 | , "exceptions"
105 | , "node-fs"
106 | , "node-buffer"
107 | , "node-readline"
108 | , "datetime"
109 | , "now"
110 | ]
111 | , repo =
112 | "https://github.com/hdgarrood/purescript-benchotron.git"
113 | , version =
114 | "v7.0.0"
115 | }
116 | }
117 | -------------------------------
118 | -}
119 | let upstream =
120 | https://github.com/purescript/package-sets/releases/download/psc-0.15.7-20230224/packages.dhall
121 | sha256:b9e82e6715e87e2a701e925d5d1414bff8f7e923172bf58c2d9d77b0fa81b578
122 |
123 | let overrides = {=}
124 |
125 | let jsonHelpers =
126 | { json-helpers =
127 | { dependencies =
128 | [ "arrays"
129 | , "exists"
130 | , "profunctor"
131 | , "strings"
132 | , "quickcheck"
133 | , "lcg"
134 | , "transformers"
135 | , "foldable-traversable"
136 | , "exceptions"
137 | , "node-fs"
138 | , "node-buffer"
139 | , "node-readline"
140 | , "datetime"
141 | , "now"
142 | ]
143 | , repo =
144 | "https://github.com/input-output-hk/purescript-bridge-json-helpers.git"
145 | , version = "0ff78186a949722f37218046a09abdf27d77ecfe"
146 | }
147 | }
148 |
149 | let servantSupport =
150 | { servant-support =
151 | { dependencies =
152 | [ "aff"
153 | , "affjax"
154 | , "argonaut"
155 | , "arrays"
156 | , "bifunctors"
157 | , "either"
158 | , "http-methods"
159 | , "maybe"
160 | , "newtype"
161 | , "nonempty"
162 | , "prelude"
163 | , "psci-support"
164 | , "strings"
165 | , "transformers"
166 | , "tuples"
167 | , "uri"
168 | ]
169 | , repo = "https://github.com/input-output-hk/purescript-servant-support"
170 | , version = "61f85eb0657196d4bfc80ae4736d6a6d9ebd4529"
171 | }
172 | }
173 |
174 | let webRouter =
175 | { web-router =
176 | { dependencies =
177 | [ "aff"
178 | , "effect"
179 | , "freet"
180 | , "indexed-monad"
181 | , "prelude"
182 | , "profunctor-lenses"
183 | , "routing"
184 | ]
185 | , repo = "https://github.com/robertdp/purescript-web-router.git"
186 | , version = "v0.3.0"
187 | }
188 | }
189 |
190 | let webAudio =
191 | { web-storage =
192 | { dependencies = [ "web-events", "nullable" ]
193 | , repo = "https://github.com/purescript-web/purescript-web-storage.git"
194 | , version = "6b74461e136755db70c271dc898d51776363d7e2"
195 | }
196 | , webaudio =
197 | { dependencies =
198 | [ "effect"
199 | , "arraybuffer-types"
200 | , "arrays"
201 | , "maybe"
202 | , "aff"
203 | , "foldable-traversable"
204 | , "math"
205 | , "tuples"
206 | , "strings"
207 | , "lists"
208 | , "arraybuffer"
209 | ]
210 | , repo = "https://github.com/adkelley/purescript-webaudio.git"
211 | , version = "v0.2.1"
212 | }
213 | }
214 |
215 | in upstream
216 | // overrides
217 | // jsonHelpers
218 | // servantSupport
219 | // webRouter
220 | // webAudio
221 |
--------------------------------------------------------------------------------
/client/spago.dhall:
--------------------------------------------------------------------------------
1 | {-
2 | Welcome to a Spago project!
3 | You can edit this file as you like.
4 | -}
5 | { name = "types-generation"
6 | , dependencies =
7 | [ "aff"
8 | , "affjax"
9 | , "affjax-web"
10 | , "argonaut"
11 | , "argonaut-codecs"
12 | , "arrays"
13 | , "bifunctors"
14 | , "console"
15 | , "control"
16 | , "datetime"
17 | , "debug"
18 | , "effect"
19 | , "either"
20 | , "email-validate"
21 | , "enums"
22 | , "exceptions"
23 | , "foldable-traversable"
24 | , "formatters"
25 | , "functions"
26 | , "halogen-subscriptions"
27 | , "http-methods"
28 | , "integers"
29 | , "js-date"
30 | , "json-helpers"
31 | , "lists"
32 | , "maybe"
33 | , "newtype"
34 | , "now"
35 | , "ordered-collections"
36 | , "pipes"
37 | , "prelude"
38 | , "profunctor-lenses"
39 | , "react-basic"
40 | , "react-basic-dom"
41 | , "react-basic-hooks"
42 | , "react-halo"
43 | , "refs"
44 | , "remotedata"
45 | , "routing"
46 | , "routing-duplex"
47 | , "servant-support"
48 | , "string-parsers"
49 | , "strings"
50 | , "transformers"
51 | , "tuples"
52 | , "uri"
53 | , "uuid"
54 | , "web-dom"
55 | , "web-html"
56 | , "web-router"
57 | , "web-storage"
58 | ]
59 | , packages = ./packages.dhall
60 | , sources = [ "src/**/*.purs", "test/**/*.purs" ]
61 | }
62 |
--------------------------------------------------------------------------------
/client/src/Data/Argonaut/JSONDateTime.purs:
--------------------------------------------------------------------------------
1 | module Data.Argonaut.JSONDateTime where
2 |
3 | import Prelude
4 | import Data.Argonaut (class DecodeJson, class EncodeJson, JsonDecodeError(..), decodeJson, encodeJson)
5 | import Data.DateTime (DateTime)
6 | import Data.DateTime as Date
7 | import Data.DateTime as DateTime
8 | import Data.Either (Either(..))
9 | import Data.Enum (fromEnum)
10 | import Data.Generic.Rep (class Generic)
11 | import Data.Int as Int
12 | import Data.JSDate as JSDate
13 | import Data.Maybe (Maybe(..))
14 | import Data.String as String
15 | import Data.Time as Time
16 | import Effect (Effect)
17 | import Effect.Exception (try)
18 | import Effect.Now (nowDateTime)
19 | import Effect.Unsafe (unsafePerformEffect)
20 | import StringParser (Parser, runParser)
21 | import StringParser as Parser
22 | import StringParser.CodePoints (regex)
23 |
24 | newtype JSONDateTime
25 | = JSONDateTime DateTime
26 |
27 | derive instance genericJSONDateTime :: Generic JSONDateTime _
28 |
29 | derive newtype instance eqJSONDateTime :: Eq JSONDateTime
30 |
31 | derive newtype instance ordJSONDateTime :: Ord JSONDateTime
32 |
33 | formatMonthYear :: JSONDateTime -> String
34 | formatMonthYear (JSONDateTime dt) =
35 | let
36 | date = Date.date dt
37 |
38 | month = show $ Date.month date
39 |
40 | year = show <<< fromEnum $ Date.year date
41 | in
42 | month <> " " <> year
43 |
44 | getJSONDateTime :: JSONDateTime -> DateTime
45 | getJSONDateTime (JSONDateTime x) = x
46 |
47 | nowJSONDateTime :: Effect JSONDateTime
48 | nowJSONDateTime = JSONDateTime <$> nowDateTime
49 |
50 | instance showJSONDateTime :: Show JSONDateTime where
51 | show (JSONDateTime x) =
52 | let
53 | date'' = DateTime.date x
54 |
55 | time'' = DateTime.time x
56 |
57 | date' =
58 | JSDate.jsdate
59 | { year: Int.toNumber $ fromEnum $ Date.year date''
60 | , month: Int.toNumber $ fromEnum (Date.month date'') - 1
61 | , day: Int.toNumber $ fromEnum $ Date.day date''
62 | , hour: Int.toNumber $ fromEnum $ Time.hour time''
63 | , minute: Int.toNumber $ fromEnum $ Time.minute time''
64 | , second: Int.toNumber $ fromEnum $ Time.second time''
65 | , millisecond: Int.toNumber $ fromEnum $ Time.millisecond time''
66 | }
67 |
68 | s = unsafePerformEffect $ JSDate.toISOString date'
69 |
70 | y = case String.stripSuffix (String.Pattern "Z") s of
71 | Nothing -> s
72 | Just s' -> case String.stripSuffix (String.Pattern "0") s' of
73 | Nothing -> s' <> "Z"
74 | Just s'' -> case String.stripSuffix (String.Pattern "0") s'' of
75 | Nothing -> s'' <> "Z"
76 | Just s''' -> case String.stripSuffix (String.Pattern ".0") s''' of
77 | Nothing -> s''' <> "Z"
78 | Just s'''' -> s'''' <> "Z"
79 | in
80 | y
81 |
82 | instance encodeJsonJSONDateTime :: EncodeJson JSONDateTime where
83 | encodeJson = encodeJson <<< show
84 |
85 | jsonDateTimeParser :: Parser JSONDateTime
86 | jsonDateTimeParser = do
87 | s <- regex "\\d{4}-[01]\\d-[0-3]\\dT[0-2]\\d:[0-5]\\d:[0-5]\\d\\.\\d+([+-][0-2]\\d:[0-5]\\d|Z)"
88 | case unsafePerformEffect $ try $ JSDate.parse s of
89 | Left _ -> Parser.fail "Not a datetime"
90 | Right x -> case JSDate.toDateTime x of
91 | Nothing -> Parser.fail "Not a datetime"
92 | Just y -> pure (JSONDateTime y)
93 |
94 | instance decodeJsonJSONDateTime :: DecodeJson JSONDateTime where
95 | decodeJson json = do
96 | s <- decodeJson json
97 | case runParser jsonDateTimeParser s of
98 | Left _ -> Left $ TypeMismatch "Not a datetime"
99 | Right x -> pure x
100 |
--------------------------------------------------------------------------------
/client/src/Data/UUID/Argonaut.purs:
--------------------------------------------------------------------------------
1 | module Data.UUID.Argonaut where
2 |
3 | import Prelude
4 |
5 | import Data.Argonaut.Aeson (maybeToEither)
6 | import Data.Argonaut.Decode (class DecodeJson, JsonDecodeError(..))
7 | import Data.Argonaut.Decode.Decoders (decodeString)
8 | import Data.Argonaut.Encode (class EncodeJson)
9 | import Data.Argonaut.Encode.Encoders (encodeString)
10 | import Data.Generic.Rep (class Generic)
11 | import Data.Lens (Iso')
12 | import Data.Lens.Iso.Newtype (_Newtype)
13 | import Data.Maybe (Maybe)
14 | import Data.Newtype (class Newtype, unwrap)
15 | import Data.UUID as U
16 | import Effect (Effect)
17 | import Servant.PureScript (class ToPathSegment)
18 |
19 | newtype UUID
20 | = UUID U.UUID
21 |
22 | derive instance newtypeUUID :: Newtype UUID _
23 |
24 | derive instance genericUUID :: Generic UUID _
25 |
26 | derive instance eqUUID :: Eq UUID
27 |
28 | derive instance ordUUID :: Ord UUID
29 |
30 | instance showUUID :: Show UUID where
31 | show (UUID uuid) = U.toString uuid
32 |
33 | instance ToPathSegment UUID where
34 | toPathSegment (UUID uuid) = U.toString uuid
35 |
36 | instance encodeJsonUUID :: EncodeJson UUID where
37 | encodeJson = encodeString <<< U.toString <<< unwrap
38 |
39 | instance decodeJsonUUID :: DecodeJson UUID where
40 | decodeJson =
41 | map UUID
42 | <<< maybeToEither (TypeMismatch "String in UUID format")
43 | <<< U.parseUUID
44 | <=< decodeString
45 |
46 | _UUID :: Iso' UUID U.UUID
47 | _UUID = _Newtype
48 |
49 | emptyUUID :: UUID
50 | emptyUUID = UUID U.emptyUUID
51 |
52 | genUUID :: Effect UUID
53 | genUUID = UUID <$> U.genUUID
54 |
55 | parseUUID :: String -> Maybe UUID
56 | parseUUID = map UUID <<< U.parseUUID
57 |
58 | genv3UUID :: String -> UUID -> UUID
59 | genv3UUID s = UUID <<< U.genv3UUID s <<< unwrap
60 |
61 | genv5UUID :: String -> UUID -> UUID
62 | genv5UUID s = UUID <<< U.genv5UUID s <<< unwrap
63 |
64 | toString :: UUID -> String
65 | toString = U.toString <<< unwrap
66 |
--------------------------------------------------------------------------------
/client/src/Foreign/Toast.js:
--------------------------------------------------------------------------------
1 | import { ToastContainer, toast } from 'react-toastify'
2 |
3 | export const toastContainer_ = ToastContainer;
4 | export const toast_ = toast;
5 | export const toastError_ = toast.error;
--------------------------------------------------------------------------------
/client/src/Foreign/Toast.purs:
--------------------------------------------------------------------------------
1 | module Foreign.Toast (toastContainer, toast, toastError) where
2 |
3 | import Prelude
4 | import Effect.Class (class MonadEffect, liftEffect)
5 | import Effect.Uncurried (EffectFn1, runEffectFn1)
6 | import React.Basic.Hooks (ReactComponent)
7 | import React.Basic.Hooks as React
8 |
9 | type ToastMessage
10 | = String
11 |
12 | toastContainer :: React.JSX
13 | toastContainer = React.element toastContainer_ {}
14 |
15 | -- TODO: MonadToast?
16 | toast :: forall m. MonadEffect m => ToastMessage -> m Unit
17 | toast msg = liftEffect $ runEffectFn1 toast_ msg
18 |
19 | toastError :: forall m. MonadEffect m => ToastMessage -> m Unit
20 | toastError msg = liftEffect $ runEffectFn1 toastError_ msg
21 |
22 | foreign import toastContainer_ :: ReactComponent {}
23 |
24 | foreign import toast_ :: EffectFn1 ToastMessage Unit
25 |
26 | foreign import toastError_ :: EffectFn1 ToastMessage Unit
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/API/Auth.purs:
--------------------------------------------------------------------------------
1 | -- File auto generated by purescript-bridge! --
2 | module GenTypesDemo.API.Auth where
3 |
4 | import Prelude
5 |
6 | import Control.Lazy (defer)
7 | import Data.Argonaut (encodeJson, jsonNull)
8 | import Data.Argonaut.Decode (class DecodeJson)
9 | import Data.Argonaut.Decode.Aeson (($\>), (*\>), (\>))
10 | import Data.Argonaut.Encode (class EncodeJson)
11 | import Data.Argonaut.Encode.Aeson ((>$<), (>/\<))
12 | import Data.Generic.Rep (class Generic)
13 | import Data.Lens (Iso', Lens', Prism', iso, prism')
14 | import Data.Lens.Iso.Newtype (_Newtype)
15 | import Data.Lens.Record (prop)
16 | import Data.Maybe (Maybe(..))
17 | import Data.Newtype (class Newtype, unwrap)
18 | import Data.Show.Generic (genericShow)
19 | import Data.Tuple.Nested ((/\))
20 | import Servant.PureScript (class ToHeader)
21 | import Type.Proxy (Proxy(Proxy))
22 | import Data.Argonaut.Decode.Aeson as D
23 | import Data.Argonaut.Encode.Aeson as E
24 | import Data.Map as Map
25 |
26 | newtype AuthorizationHeader = AuthorizationHeader String
27 |
28 | derive newtype instance ToHeader AuthorizationHeader
29 |
30 | derive instance Eq AuthorizationHeader
31 |
32 | derive instance Ord AuthorizationHeader
33 |
34 | instance Show AuthorizationHeader where
35 | show a = genericShow a
36 |
37 | instance EncodeJson AuthorizationHeader where
38 | encodeJson = defer \_ -> E.encode $ unwrap >$< E.value
39 |
40 | instance DecodeJson AuthorizationHeader where
41 | decodeJson = defer \_ -> D.decode $ (AuthorizationHeader <$> D.value)
42 |
43 | derive instance Generic AuthorizationHeader _
44 |
45 | derive instance Newtype AuthorizationHeader _
46 |
47 | --------------------------------------------------------------------------------
48 |
49 | _AuthorizationHeader :: Iso' AuthorizationHeader String
50 | _AuthorizationHeader = _Newtype
51 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/API/Call.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.API.Call where
2 |
3 | import Prelude
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/API/Error.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.API.Error where
2 |
3 | import Prelude
4 | import Data.Argonaut (Json, decodeJson, printJsonDecodeError, stringify)
5 | import Data.Argonaut.Decode (JsonDecodeError)
6 | import Data.Either (Either(..))
7 | import Data.Maybe (Maybe(..))
8 | import GenTypesDemo.API.Types (Error)
9 | import Servant.PureScript (AjaxError(..), printAjaxError)
10 |
11 | data APIError
12 | = APIError (AjaxError JsonDecodeError Json)
13 | | UnauthorizedAccess
14 |
15 | data APIErrorContents
16 | = ValidationError Error
17 | | UnknownError (Maybe Json)
18 |
19 | withErrorContents :: forall m. Monad m => APIError -> (APIErrorContents -> m Unit) -> m Unit
20 | withErrorContents (APIError (AjaxError { response })) action = case _.body <$> response of
21 | Just res -> case decodeJson res of
22 | Right apiError -> action (ValidationError apiError)
23 | Left _otherError -> action (UnknownError $ Just res)
24 | Nothing -> action (UnknownError Nothing)
25 |
26 | withErrorContents _ _ = pure unit
27 |
28 | printAPIError :: APIError -> String
29 | printAPIError (APIError ajax) = printAjaxError ajax
30 |
31 | printAPIError UnauthorizedAccess = "Unauthorized access."
32 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/API/Types.purs:
--------------------------------------------------------------------------------
1 | -- File auto generated by purescript-bridge! --
2 | module GenTypesDemo.API.Types where
3 |
4 | import Prelude
5 |
6 | import Control.Lazy (defer)
7 | import Data.Argonaut (encodeJson, jsonNull)
8 | import Data.Argonaut.Decode (class DecodeJson)
9 | import Data.Argonaut.Decode.Aeson (($\>), (*\>), (\>))
10 | import Data.Argonaut.Encode (class EncodeJson)
11 | import Data.Argonaut.Encode.Aeson ((>$<), (>/\<))
12 | import Data.Argonaut.JSONDateTime (JSONDateTime)
13 | import Data.Generic.Rep (class Generic)
14 | import Data.Lens (Iso', Lens', Prism', iso, prism')
15 | import Data.Lens.Iso.Newtype (_Newtype)
16 | import Data.Lens.Record (prop)
17 | import Data.Maybe (Maybe(..))
18 | import Data.Newtype (class Newtype, unwrap)
19 | import Data.Show.Generic (genericShow)
20 | import Data.Tuple.Nested ((/\))
21 | import Data.UUID.Argonaut (UUID)
22 | import GenTypesDemo.Utilities.Email (Email)
23 | import Servant.PureScript (class ToPathSegment)
24 | import Type.Proxy (Proxy(Proxy))
25 | import Data.Argonaut.Decode.Aeson as D
26 | import Data.Argonaut.Encode.Aeson as E
27 | import Data.Map as Map
28 |
29 | newtype CreateUserRequest = CreateUserRequest
30 | { email :: Email
31 | , username :: Username
32 | }
33 |
34 | instance Show CreateUserRequest where
35 | show a = genericShow a
36 |
37 | derive instance Eq CreateUserRequest
38 |
39 | instance EncodeJson CreateUserRequest where
40 | encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record
41 | { email: E.value :: _ Email
42 | , username: E.value :: _ Username
43 | })
44 |
45 | instance DecodeJson CreateUserRequest where
46 | decodeJson = defer \_ -> D.decode $ (CreateUserRequest <$> D.record "CreateUserRequest"
47 | { email: D.value :: _ Email
48 | , username: D.value :: _ Username
49 | })
50 |
51 | derive instance Generic CreateUserRequest _
52 |
53 | derive instance Newtype CreateUserRequest _
54 |
55 | --------------------------------------------------------------------------------
56 |
57 | _CreateUserRequest :: Iso' CreateUserRequest {email :: Email, username :: Username}
58 | _CreateUserRequest = _Newtype
59 |
60 | --------------------------------------------------------------------------------
61 |
62 | newtype CreatedAt = CreatedAt JSONDateTime
63 |
64 | derive instance Eq CreatedAt
65 |
66 | derive instance Ord CreatedAt
67 |
68 | instance Show CreatedAt where
69 | show a = genericShow a
70 |
71 | instance EncodeJson CreatedAt where
72 | encodeJson = defer \_ -> E.encode $ unwrap >$< E.value
73 |
74 | instance DecodeJson CreatedAt where
75 | decodeJson = defer \_ -> D.decode $ (CreatedAt <$> D.value)
76 |
77 | derive instance Generic CreatedAt _
78 |
79 | derive instance Newtype CreatedAt _
80 |
81 | --------------------------------------------------------------------------------
82 |
83 | _CreatedAt :: Iso' CreatedAt JSONDateTime
84 | _CreatedAt = _Newtype
85 |
86 | --------------------------------------------------------------------------------
87 |
88 | newtype Error = Error
89 | { error :: String
90 | , status :: Int
91 | }
92 |
93 | derive instance Eq Error
94 |
95 | derive instance Ord Error
96 |
97 | instance Show Error where
98 | show a = genericShow a
99 |
100 | instance EncodeJson Error where
101 | encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record
102 | { error: E.value :: _ String
103 | , status: E.value :: _ Int
104 | })
105 |
106 | instance DecodeJson Error where
107 | decodeJson = defer \_ -> D.decode $ (Error <$> D.record "Error"
108 | { error: D.value :: _ String
109 | , status: D.value :: _ Int
110 | })
111 |
112 | derive instance Generic Error _
113 |
114 | derive instance Newtype Error _
115 |
116 | --------------------------------------------------------------------------------
117 |
118 | _Error :: Iso' Error {error :: String, status :: Int}
119 | _Error = _Newtype
120 |
121 | --------------------------------------------------------------------------------
122 |
123 | newtype UpdateUserRequest = UpdateUserRequest
124 | { newEmail :: Maybe Email
125 | , newUsername :: Maybe Username
126 | }
127 |
128 | instance Show UpdateUserRequest where
129 | show a = genericShow a
130 |
131 | derive instance Eq UpdateUserRequest
132 |
133 | instance EncodeJson UpdateUserRequest where
134 | encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record
135 | { newEmail: (E.maybe E.value) :: _ (Maybe Email)
136 | , newUsername: (E.maybe E.value) :: _ (Maybe Username)
137 | })
138 |
139 | instance DecodeJson UpdateUserRequest where
140 | decodeJson = defer \_ -> D.decode $ (UpdateUserRequest <$> D.record "UpdateUserRequest"
141 | { newEmail: (D.maybe D.value) :: _ (Maybe Email)
142 | , newUsername: (D.maybe D.value) :: _ (Maybe Username)
143 | })
144 |
145 | derive instance Generic UpdateUserRequest _
146 |
147 | derive instance Newtype UpdateUserRequest _
148 |
149 | --------------------------------------------------------------------------------
150 |
151 | _UpdateUserRequest :: Iso' UpdateUserRequest {newEmail :: Maybe Email, newUsername :: Maybe Username}
152 | _UpdateUserRequest = _Newtype
153 |
154 | --------------------------------------------------------------------------------
155 |
156 | newtype User = User
157 | { id :: UserId
158 | , info :: UserData
159 | }
160 |
161 | instance Show User where
162 | show a = genericShow a
163 |
164 | derive instance Eq User
165 |
166 | instance EncodeJson User where
167 | encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record
168 | { id: E.value :: _ UserId
169 | , info: E.value :: _ UserData
170 | })
171 |
172 | instance DecodeJson User where
173 | decodeJson = defer \_ -> D.decode $ (User <$> D.record "User"
174 | { id: D.value :: _ UserId
175 | , info: D.value :: _ UserData
176 | })
177 |
178 | derive instance Generic User _
179 |
180 | derive instance Newtype User _
181 |
182 | --------------------------------------------------------------------------------
183 |
184 | _User :: Iso' User {id :: UserId, info :: UserData}
185 | _User = _Newtype
186 |
187 | --------------------------------------------------------------------------------
188 |
189 | newtype UserData = UserData
190 | { email :: Email
191 | , username :: Username
192 | , created :: CreatedAt
193 | }
194 |
195 | instance Show UserData where
196 | show a = genericShow a
197 |
198 | derive instance Eq UserData
199 |
200 | instance EncodeJson UserData where
201 | encodeJson = defer \_ -> E.encode $ unwrap >$< (E.record
202 | { email: E.value :: _ Email
203 | , username: E.value :: _ Username
204 | , created: E.value :: _ CreatedAt
205 | })
206 |
207 | instance DecodeJson UserData where
208 | decodeJson = defer \_ -> D.decode $ (UserData <$> D.record "UserData"
209 | { email: D.value :: _ Email
210 | , username: D.value :: _ Username
211 | , created: D.value :: _ CreatedAt
212 | })
213 |
214 | derive instance Generic UserData _
215 |
216 | derive instance Newtype UserData _
217 |
218 | --------------------------------------------------------------------------------
219 |
220 | _UserData :: Iso' UserData {email :: Email, username :: Username, created :: CreatedAt}
221 | _UserData = _Newtype
222 |
223 | --------------------------------------------------------------------------------
224 |
225 | newtype UserId = UserId UUID
226 |
227 | derive newtype instance ToPathSegment UserId
228 |
229 | derive instance Eq UserId
230 |
231 | derive instance Ord UserId
232 |
233 | instance Show UserId where
234 | show a = genericShow a
235 |
236 | instance EncodeJson UserId where
237 | encodeJson = defer \_ -> E.encode $ unwrap >$< E.value
238 |
239 | instance DecodeJson UserId where
240 | decodeJson = defer \_ -> D.decode $ (UserId <$> D.value)
241 |
242 | derive instance Generic UserId _
243 |
244 | derive instance Newtype UserId _
245 |
246 | --------------------------------------------------------------------------------
247 |
248 | _UserId :: Iso' UserId UUID
249 | _UserId = _Newtype
250 |
251 | --------------------------------------------------------------------------------
252 |
253 | newtype Username = Username String
254 |
255 | derive instance Eq Username
256 |
257 | derive instance Ord Username
258 |
259 | instance Show Username where
260 | show a = genericShow a
261 |
262 | instance EncodeJson Username where
263 | encodeJson = defer \_ -> E.encode $ unwrap >$< E.value
264 |
265 | instance DecodeJson Username where
266 | decodeJson = defer \_ -> D.decode $ (Username <$> D.value)
267 |
268 | derive instance Generic Username _
269 |
270 | derive instance Newtype Username _
271 |
272 | --------------------------------------------------------------------------------
273 |
274 | _Username :: Iso' Username String
275 | _Username = _Newtype
276 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Aggregate/Class.purs:
--------------------------------------------------------------------------------
1 | -- File auto generated by purescript-bridge! --
2 | module GenTypesDemo.Aggregate.Class where
3 |
4 | import Prelude
5 |
6 | import Control.Lazy (defer)
7 | import Data.Argonaut (encodeJson, jsonNull)
8 | import Data.Argonaut.Decode (class DecodeJson)
9 | import Data.Argonaut.Decode.Aeson (($\>), (*\>), (\>))
10 | import Data.Argonaut.Encode (class EncodeJson)
11 | import Data.Argonaut.Encode.Aeson ((>$<), (>/\<))
12 | import Data.Argonaut.JSONDateTime (JSONDateTime)
13 | import Data.Generic.Rep (class Generic)
14 | import Data.Lens (Iso', Lens', Prism', iso, prism')
15 | import Data.Lens.Iso.Newtype (_Newtype)
16 | import Data.Lens.Record (prop)
17 | import Data.Maybe (Maybe(..))
18 | import Data.Newtype (class Newtype, unwrap)
19 | import Data.Show.Generic (genericShow)
20 | import Data.Tuple.Nested ((/\))
21 | import Type.Proxy (Proxy(Proxy))
22 | import Data.Argonaut.Decode.Aeson as D
23 | import Data.Argonaut.Encode.Aeson as E
24 | import Data.Map as Map
25 |
26 | newtype LastEdit = LastEdit JSONDateTime
27 |
28 | derive instance Eq LastEdit
29 |
30 | derive instance Ord LastEdit
31 |
32 | instance Show LastEdit where
33 | show a = genericShow a
34 |
35 | instance EncodeJson LastEdit where
36 | encodeJson = defer \_ -> E.encode $ unwrap >$< E.value
37 |
38 | instance DecodeJson LastEdit where
39 | decodeJson = defer \_ -> D.decode $ (LastEdit <$> D.value)
40 |
41 | derive instance Generic LastEdit _
42 |
43 | derive instance Newtype LastEdit _
44 |
45 | --------------------------------------------------------------------------------
46 |
47 | _LastEdit :: Iso' LastEdit JSONDateTime
48 | _LastEdit = _Newtype
49 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Aggregate/Events.purs:
--------------------------------------------------------------------------------
1 | -- File auto generated by purescript-bridge! --
2 | module GenTypesDemo.Aggregate.Events where
3 |
4 | import Prelude
5 |
6 | import Control.Lazy (defer)
7 | import Data.Argonaut (encodeJson, jsonNull)
8 | import Data.Argonaut.Decode (class DecodeJson)
9 | import Data.Argonaut.Decode.Aeson (($\>), (*\>), (\>))
10 | import Data.Argonaut.Encode (class EncodeJson)
11 | import Data.Argonaut.Encode.Aeson ((>$<), (>/\<))
12 | import Data.Generic.Rep (class Generic)
13 | import Data.Lens (Iso', Lens', Prism', iso, prism')
14 | import Data.Lens.Iso.Newtype (_Newtype)
15 | import Data.Lens.Record (prop)
16 | import Data.Maybe (Maybe(..))
17 | import Data.Newtype (class Newtype, unwrap)
18 | import Data.Show.Generic (genericShow)
19 | import Data.Tuple.Nested ((/\))
20 | import Type.Proxy (Proxy(Proxy))
21 | import Data.Argonaut.Decode.Aeson as D
22 | import Data.Argonaut.Encode.Aeson as E
23 | import Data.Map as Map
24 |
25 | newtype AggregateVersion = AggregateVersion Int
26 |
27 | derive instance Eq AggregateVersion
28 |
29 | derive instance Ord AggregateVersion
30 |
31 | instance Show AggregateVersion where
32 | show a = genericShow a
33 |
34 | instance EncodeJson AggregateVersion where
35 | encodeJson = defer \_ -> E.encode $ unwrap >$< E.value
36 |
37 | instance DecodeJson AggregateVersion where
38 | decodeJson = defer \_ -> D.decode $ (AggregateVersion <$> D.value)
39 |
40 | derive instance Generic AggregateVersion _
41 |
42 | derive instance Newtype AggregateVersion _
43 |
44 | --------------------------------------------------------------------------------
45 |
46 | _AggregateVersion :: Iso' AggregateVersion Int
47 | _AggregateVersion = _Newtype
48 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/AppM.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.AppM where
2 |
3 | import Prelude
4 |
5 | import Affjax.RequestBody (RequestBody(..))
6 | import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)
7 | import Data.Argonaut (Json, JsonDecodeError)
8 | import Data.Bifunctor (lmap)
9 | import Data.Either (Either(..))
10 | import Data.Lens ((.~), (^.))
11 | import Data.Lens.Record (prop)
12 | import Data.Maybe (Maybe(..), fromMaybe)
13 | import Data.String.NonEmpty (NonEmptyString)
14 | import Data.String.NonEmpty.Internal (NonEmptyString(..))
15 | import Effect.Aff (Aff)
16 | import Effect.Aff.Class (class MonadAff)
17 | import Effect.Class (class MonadEffect, liftEffect)
18 | import Effect.Class.Console as Console
19 | import Effect.Now as Now
20 | import GenTypesDemo.API.Auth (AuthorizationHeader(..))
21 | import GenTypesDemo.API.Error (APIError(..))
22 | import GenTypesDemo.Capability.Global (GlobalEvent(..), GlobalIO, emitGlobalAction, emitGlobalEvent)
23 | import GenTypesDemo.Capability.Global (class MonadGlobal)
24 | import GenTypesDemo.Capability.Halo (class MonadHalo)
25 | import GenTypesDemo.Capability.Log (class LogMessages)
26 | import GenTypesDemo.Capability.Now (class Now)
27 | import GenTypesDemo.Capability.Routing (class MonadRouting)
28 | import GenTypesDemo.Capability.Users (class MonadUsers)
29 | import GenTypesDemo.Component.Routing (RoutingIO)
30 | import GenTypesDemo.Config as Config
31 | import GenTypesDemo.Data.Log as Log
32 | import Halogen.Subscription as HS
33 | import Network.RemoteData (RemoteData)
34 | import Network.RemoteData as RemoteData
35 | import Pipes.Core (Proxy)
36 | import React.Basic.Hooks as React
37 | import React.Halo (component, hoist) as Halo
38 | import React.Halo (component, hoist, useHalo) as Halo
39 | import Servant.PureScript (class MonadAjax, AjaxError(..), Request, request)
40 | import Servant.PureScript (class MonadAjax, Request, request)
41 | import ServerAPI (Api)
42 | import ServerAPI (Api)
43 | import ServerAPI as Server
44 | import ServerAPI as ServerAPI
45 | import Type.Proxy (Proxy(..))
46 | import URI (Authority(..), Host(..), RelativePart(..))
47 | import URI.Host.RegName as RegName
48 | import URI.Path (Path(..))
49 | import URI.Path.Segment (segmentFromString)
50 | import URI.RelativePart (_path, _relPath)
51 | import URI.RelativeRef (_relPart)
52 |
53 | data LogLevel
54 | = Dev
55 | | Prod
56 |
57 | instance Show LogLevel where
58 | show Dev = "Dev"
59 | show Prod = "Prod"
60 |
61 | derive instance eqLogLevel :: Eq LogLevel
62 |
63 | derive instance ordLogLevel :: Ord LogLevel
64 |
65 | type Env
66 | = { routing :: RoutingIO
67 | , logLevel :: LogLevel
68 | , globalIO :: GlobalIO
69 | }
70 |
71 | newtype AppM a
72 | = AppM (ReaderT Env Aff a)
73 |
74 | runAppM :: forall a. Env -> AppM a -> Aff a
75 | runAppM env (AppM act) = runReaderT act env
76 |
77 | -- | Halo
78 | instance monadHaloAppM :: MonadHalo AppM where
79 | component name spec =
80 | AppM do
81 | env <- ask
82 | liftEffect
83 | $ Halo.component name
84 | spec { eval = Halo.hoist (runAppM env) <<< spec.eval }
85 |
86 | derive newtype instance functorAppM :: Functor AppM
87 |
88 | derive newtype instance applyAppM :: Apply AppM
89 |
90 | derive newtype instance applicativeAppM :: Applicative AppM
91 |
92 | derive newtype instance bindAppM :: Bind AppM
93 |
94 | derive newtype instance monadAppM :: Monad AppM
95 |
96 | derive newtype instance monadEffectAppM :: MonadEffect AppM
97 |
98 | derive newtype instance monadAffAppM :: MonadAff AppM
99 |
100 | instance nowAppM :: Now AppM where
101 | now = liftEffect Now.now
102 | nowDate = liftEffect Now.nowDate
103 | nowTime = liftEffect Now.nowTime
104 | nowDateTime = liftEffect Now.nowDateTime
105 |
106 | instance logMessagesAppM :: LogMessages AppM where
107 | logMessage log = do
108 | logLevel <- AppM $ asks _.logLevel
109 | liftEffect case logLevel, Log.reason log of
110 | Prod, Log.Debug -> pure unit
111 | _, _ -> Console.log $ Log.message log
112 |
113 | instance monadAjaxAppM :: MonadAjax Api AppM where
114 | request api = AppM <<< request api <<< setAuthority Config.apiUrl
115 |
116 | instance monadGlobalAppM :: MonadGlobal AppM where
117 | emitGlobalAction act = AppM $ do
118 | listener <- asks (\s -> s.globalIO.actionsListener)
119 | liftEffect $ HS.notify listener act
120 | emitGlobalEvent ev = AppM $ do
121 | listener <- asks (\s -> s.globalIO.eventsListener)
122 | liftEffect $ HS.notify listener ev
123 | getGlobalEventsEmitter = AppM $ asks (\s -> s.globalIO.eventsEmitter)
124 | getGlobalActionsEmitter = AppM $ asks (\s -> s.globalIO.actionsEmitter)
125 |
126 | instance monadRoutingAppM :: MonadRouting AppM where
127 | read = liftEffect =<< (AppM $ asks _.routing.read)
128 | reload = liftEffect =<< (AppM $ asks _.routing.reload)
129 | getEmitter = AppM $ asks _.routing.emitter
130 | navigate route = do
131 | f <- AppM $ asks _.routing.navigate
132 | liftEffect $ f route
133 | redirect route = do
134 | f <- AppM $ asks _.routing.redirect
135 | liftEffect $ f route
136 |
137 | instance monadUsersAppM :: MonadUsers AppM where
138 | listUsers = callApi ServerAPI.getUsers
139 | newUser = callApi <<< ServerAPI.postUser
140 | deleteUser uId = getAuthHeader >>= \authHeader ->
141 | callApi $ ServerAPI.deleteUserByUserId authHeader uId
142 |
143 | getAuthHeader :: AppM (Maybe AuthorizationHeader)
144 | getAuthHeader =
145 | -- Imagine you're reading this from some magical place
146 | pure $ Just $ AuthorizationHeader "Bearer eyJhbGciOiJIUzI1NiJ9.eyJ1c2VybmFtZSI6InRlc3QiLCJleHAiOjE5NzM1NDg4MDB9.Li3xg_6ikx7PQlPR6ca_WB6KV3xJnBnjDnB3AbQUFWI"
147 |
148 | callApi ::
149 | forall m result.
150 | Monad m =>
151 | MonadGlobal m =>
152 | m (Either (AjaxError JsonDecodeError Json) result) ->
153 | m (Either APIError result)
154 | callApi apiCall = do
155 | apiCall >>= \result ->
156 | case result of
157 | Left err -> do
158 | emitGlobalEvent $ APIErrorOccurred (APIError err)
159 | pure $ Left (APIError err)
160 | Right validResponse -> pure $ Right validResponse
161 |
162 |
163 | setAuthority ::
164 | forall reqContent resContent decodeError req res.
165 | String ->
166 | Request reqContent resContent decodeError req res ->
167 | Request reqContent resContent decodeError req res
168 | setAuthority apiUrl req =
169 | let
170 | rel = req ^. prop (Proxy :: _ "uri")
171 |
172 | auth =
173 | ( Authority
174 | Nothing
175 | (NameAddress (RegName.unsafeFromString $ NonEmptyString apiUrl))
176 | )
177 |
178 | (currentRelPath :: Array String) =
179 | fromMaybe []
180 | $ rel
181 | ^. _relPart
182 | <<< _relPath
183 |
184 | newPart =
185 | RelativePartAuth auth
186 | $ Path (map segmentFromString currentRelPath)
187 |
188 | updated = rel # _relPart .~ newPart
189 | in
190 | req # prop (Proxy :: _ "uri") .~ updated
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Capability/Global.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Capability.Global where
2 |
3 | import Prelude
4 |
5 | import Control.Monad.Trans.Class (lift)
6 | import Effect (Effect)
7 | import GenTypesDemo.API.Error (APIError(..))
8 | import Halogen.Subscription as HS
9 | import React.Halo (HaloM)
10 | import React.Halo as Halo
11 |
12 | data GlobalAction = UseMeForIssuingMassCommands
13 |
14 | data GlobalEvent =
15 | APIErrorOccurred APIError
16 |
17 | type GlobalIO
18 | = { eventsEmitter :: HS.Emitter GlobalEvent
19 | , eventsListener :: HS.Listener GlobalEvent
20 | , actionsEmitter :: HS.Emitter GlobalAction
21 | , actionsListener :: HS.Listener GlobalAction
22 | }
23 |
24 | class Monad m <= MonadGlobal m where
25 | emitGlobalAction :: GlobalAction -> m Unit
26 | emitGlobalEvent :: GlobalEvent -> m Unit
27 | getGlobalEventsEmitter :: m (HS.Emitter GlobalEvent)
28 | getGlobalActionsEmitter :: m (HS.Emitter GlobalAction)
29 |
30 | instance MonadGlobal m => MonadGlobal (HaloM props state action m) where
31 | emitGlobalAction = lift <<< emitGlobalAction
32 | emitGlobalEvent = lift <<< emitGlobalEvent
33 | getGlobalEventsEmitter = lift getGlobalEventsEmitter
34 | getGlobalActionsEmitter = lift getGlobalActionsEmitter
35 |
36 | subscribeForGlobalEvents :: forall m props state action. MonadGlobal m => (GlobalEvent -> action) -> HaloM props state action m Unit
37 | subscribeForGlobalEvents f = do
38 | emitter <- lift getGlobalEventsEmitter
39 | void $ Halo.subscribe $ f <$> emitter
40 |
41 | subscribeForGlobalActions :: forall m props state action. MonadGlobal m => (GlobalAction -> action) -> HaloM props state action m Unit
42 | subscribeForGlobalActions f = do
43 | emitter <- lift getGlobalActionsEmitter
44 | void $ Halo.subscribe $ f <$> emitter
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Capability/Halo.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Capability.Halo
2 | ( class MonadHalo
3 | , component
4 | ) where
5 |
6 | import Prelude
7 | import React.Basic.Hooks (JSX)
8 | import React.Halo (ComponentSpec)
9 |
10 | class
11 | Monad m <= MonadHalo m where
12 | component :: forall props state action. String -> ComponentSpec props state action m -> m (props -> JSX)
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Capability/Log.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Capability.Log where
2 |
3 | import Prelude
4 | import Control.Monad.Trans.Class (lift)
5 | import Data.Either (Either(..))
6 | import Data.Maybe (Maybe(..))
7 | import React.Halo (HaloM)
8 | import GenTypesDemo.Capability.Now (class Now)
9 | import GenTypesDemo.Data.Log (Log, LogReason(..), mkLog)
10 |
11 | class
12 | Monad m <= LogMessages m where
13 | logMessage :: Log -> m Unit
14 |
15 | -- | This instance lets us avoid having to use `lift` when we use these functions in a component.
16 | instance logMessagesHalogenM :: LogMessages m => LogMessages (HaloM props state action m) where
17 | logMessage = lift <<< logMessage
18 |
19 | log :: forall m. LogMessages m => Now m => LogReason -> String -> m Unit
20 | log reason = logMessage <=< mkLog reason
21 |
22 | -- | Log a message for debugging purposes
23 | logDebug :: forall m. LogMessages m => Now m => String -> m Unit
24 | logDebug = log Debug
25 |
26 | -- | Log a message to convey non-error information
27 | logInfo :: forall m. LogMessages m => Now m => String -> m Unit
28 | logInfo = log Info
29 |
30 | -- | Log a message as a warning
31 | logWarn :: forall m. LogMessages m => Now m => String -> m Unit
32 | logWarn = log Warn
33 |
34 | -- | Log a message as an error
35 | logError :: forall m. LogMessages m => Now m => String -> m Unit
36 | logError = log Error
37 |
38 | -- | Hush a monadic action by logging the error, leaving it open why the error is being logged
39 | logHush :: forall m a. LogMessages m => Now m => LogReason -> m (Either String a) -> m (Maybe a)
40 | logHush reason action =
41 | action
42 | >>= case _ of
43 | Left e -> case reason of
44 | Debug -> logDebug e *> pure Nothing
45 | Info -> logInfo e *> pure Nothing
46 | Warn -> logWarn e *> pure Nothing
47 | Error -> logError e *> pure Nothing
48 | Right v -> pure $ Just v
49 |
50 | -- | Hush a monadic action by logging the error in debug mode
51 | debugHush :: forall m a. LogMessages m => Now m => m (Either String a) -> m (Maybe a)
52 | debugHush = logHush Debug
53 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Capability/Now.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Capability.Now where
2 |
3 | import Prelude
4 | import Control.Monad.Trans.Class (lift)
5 | import Data.DateTime (Date, DateTime, Time)
6 | import Data.DateTime.Instant (Instant)
7 | import React.Halo (HaloM)
8 |
9 | class
10 | Monad m <= Now m where
11 | now :: m Instant
12 | nowDate :: m Date
13 | nowTime :: m Time
14 | nowDateTime :: m DateTime
15 |
16 | instance nowHalogenM :: Now m => Now (HaloM props state action m) where
17 | now = lift now
18 | nowDate = lift nowDate
19 | nowTime = lift nowTime
20 | nowDateTime = lift nowDateTime
21 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Capability/Routing.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Capability.Routing where
2 |
3 | import Prelude
4 | import GenTypesDemo.Data.Route (Route)
5 | import Control.Monad.Trans.Class (lift)
6 | import Halogen.Subscription as HS
7 | import React.Halo (HaloM)
8 | import React.Halo as Halo
9 |
10 | class
11 | Monad m <=
12 | MonadRouting m where
13 | read :: m Route
14 | getEmitter :: m (HS.Emitter Route)
15 | navigate :: Route -> m Unit
16 | redirect :: Route -> m Unit
17 | reload :: m Unit
18 |
19 | instance MonadRouting m => MonadRouting (HaloM props state action m) where
20 | read = lift read
21 | reload = lift reload
22 | getEmitter = lift getEmitter
23 | navigate = lift <<< navigate
24 | redirect = lift <<< redirect
25 |
26 | subscribe :: forall m props state action. MonadRouting m => (Route -> action) -> HaloM props state action m Unit
27 | subscribe f = do
28 | emitter <- lift getEmitter
29 | void $ Halo.subscribe $ f <$> emitter
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Capability/Users.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Capability.Users where
2 |
3 | import Prelude
4 |
5 | import Control.Monad.Cont (lift)
6 | import Data.Either (Either)
7 | import GenTypesDemo.API.Error (APIError(..))
8 | import GenTypesDemo.API.Types (CreateUserRequest(..), User(..), UserId(..))
9 | import React.Halo (HaloM)
10 |
11 | class
12 | Monad m <= MonadUsers m where
13 | listUsers :: m (Either APIError (Array User))
14 | newUser :: CreateUserRequest -> m (Either APIError User)
15 | deleteUser :: UserId -> m (Either APIError Unit)
16 |
17 | instance monadUsersHalogenM :: MonadUsers m => MonadUsers (HaloM props state action m) where
18 | listUsers = lift listUsers
19 | newUser = lift <<< newUser
20 | deleteUser = lift <<< deleteUser
21 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Component/GlobalContext.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Component.GlobalContext where
2 |
3 | import Prelude
4 |
5 | import Data.Maybe (Maybe(..))
6 | import Effect.Class (class MonadEffect)
7 | import Foreign.Toast (toast, toastError)
8 | import GenTypesDemo.API.Error (APIErrorContents(..), withErrorContents)
9 | import GenTypesDemo.API.Types (Error(..))
10 | import GenTypesDemo.Capability.Global (class MonadGlobal, GlobalAction, GlobalEvent(..), subscribeForGlobalActions, subscribeForGlobalEvents)
11 | import GenTypesDemo.Capability.Halo (class MonadHalo, component)
12 | import React.Basic.DOM as R
13 | import React.Basic.Hooks as React
14 | import React.Halo as Halo
15 |
16 | data Action
17 | = Initialize
18 | | HandleGlobalAction GlobalAction
19 | | HandleGlobalEvent GlobalEvent
20 |
21 | mkGlobalContext ::
22 | forall m.
23 | MonadGlobal m =>
24 | MonadHalo m =>
25 | MonadEffect m =>
26 | m (Unit -> React.JSX)
27 | mkGlobalContext = component "GlobalContext" { initialState, eval, render }
28 | where
29 | initialState _ = unit
30 |
31 | eval =
32 | Halo.mkEval Halo.defaultEval
33 | { onInitialize = \_ -> Just Initialize
34 | , onAction = handleAction
35 | }
36 |
37 | handleAction a = case a of
38 | Initialize -> do
39 | subscribeForGlobalActions HandleGlobalAction
40 | subscribeForGlobalEvents HandleGlobalEvent
41 | HandleGlobalAction globalAction -> case globalAction of
42 | _ -> pure unit
43 | HandleGlobalEvent ev -> case ev of
44 | APIErrorOccurred apiError -> do
45 | withErrorContents apiError
46 | $ \err -> case err of
47 | ValidationError (Error { error }) -> toastError error
48 | UnknownError _ -> toastError "An unknown error occurred!"
49 | pure unit
50 |
51 | render _ = R.div {}
52 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Component/NewUserRow.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Component.NewUserRow where
2 |
3 | import Prelude
4 | import Data.Maybe (Maybe(..), fromMaybe)
5 | import Data.Tuple.Nested ((/\))
6 | import Effect (Effect)
7 | import Effect.Class (class MonadEffect, liftEffect)
8 | import GenTypesDemo.API.Types (CreateUserRequest(..), Username(..))
9 | import GenTypesDemo.Utilities.Email (Email, mkEmail)
10 | import React.Basic.DOM as R
11 | import React.Basic.DOM.Events (targetValue)
12 | import React.Basic.Events (handler, handler_)
13 | import React.Basic.Hooks as React
14 |
15 | type Props
16 | = { onSubmit :: CreateUserRequest -> Effect Unit
17 | }
18 |
19 | mkNewUserRow ::
20 | forall m.
21 | MonadEffect m =>
22 | m (Props -> React.JSX)
23 | mkNewUserRow =
24 | liftEffect
25 | $ React.component "NewUserRow"
26 | $ \{ onSubmit } -> React.do
27 | (username /\ setUsername) <- React.useState ""
28 | (email /\ setEmail) <- React.useState ""
29 | (validationError /\ setValidationError) <- React.useState Nothing
30 | let
31 | clearFields = do
32 | setUsername (const "")
33 | setEmail (const "")
34 | setValidationError (const Nothing)
35 |
36 | handleSubmit = do
37 | case mkEmail email of
38 | Just validEmail -> do
39 | setValidationError (const Nothing)
40 | clearFields
41 | onSubmit (CreateUserRequest { username: Username username, email: validEmail })
42 | Nothing -> setValidationError (const $ Just "Invalid email.")
43 | pure
44 | $ R.div
45 | { className: "mt-8 space-y-4 flex flex-col bg-white rounded-lg border-blue-100 p-2"
46 | , children:
47 | [ case validationError of
48 | Just err ->
49 | R.div
50 | { className: "bg-red-4 text-white p-2 rounded-lg"
51 | , children: [ R.text err ]
52 | }
53 | Nothing -> React.empty
54 | , R.div
55 | { className: "space-x-4 flex flex-row items-center"
56 | , children:
57 | [ R.input
58 | { type: "text"
59 | , className: "p-2 border border-slate-100 rounded-md"
60 | , placeholder: "Username"
61 | , value: username
62 | , onChange: handler targetValue (\val -> setUsername (const <<< fromMaybe "" $ val))
63 | }
64 | , R.input
65 | { type: "text"
66 | , className: "p-2 border border-slate-100 rounded-md"
67 | , placeholder: "Email"
68 | , value: email
69 | , onChange: handler targetValue (\val -> setEmail (const <<< fromMaybe "" $ val))
70 | }
71 | , R.button
72 | { className: "p-2 bg-gold-4 rounded-md text-gray-9"
73 | , onClick: handler_ handleSubmit
74 | , children:
75 | [ R.text "Add User"
76 | ]
77 | }
78 | ]
79 | }
80 | ]
81 | }
82 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Component/Routing.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Component.Routing where
2 |
3 | import Prelude
4 |
5 | import Data.Either (either)
6 | import Data.Tuple.Nested (type (/\), (/\))
7 | import Effect (Effect)
8 | import Effect.Class (liftEffect)
9 | import Effect.Class.Console (log)
10 | import Effect.Ref as Ref
11 | import Halogen.Subscription as HS
12 | import GenTypesDemo.Data.Route (Route(..), routeCodec)
13 | import React.Basic.Hooks as React
14 | import Routing.Duplex (parse, print)
15 | import Routing.PushState as PushState
16 | import Web.HTML (window)
17 | import Web.HTML.Location (reload)
18 | import Web.HTML.Window (location)
19 | import Web.Router as Router
20 | import Web.Router.Driver.PushState as Driver
21 |
22 | type RoutingIO
23 | = { read :: Effect Route
24 | , emitter :: HS.Emitter Route
25 | , navigate :: Route -> Effect Unit
26 | , redirect :: Route -> Effect Unit
27 | , reload :: Effect Unit
28 | }
29 |
30 | mkRoutingManager :: Effect (RoutingIO /\ React.JSX)
31 | mkRoutingManager = do
32 | interface <- PushState.makeInterface
33 | { path } <- interface.locationState
34 | value <- Ref.new $ either (const Error) identity $ parse routeCodec path
35 | { emitter, listener } <- HS.create
36 | let
37 | driver = Driver.makeDriver_ (parse routeCodec) (print routeCodec) interface
38 | router <-
39 | Router.makeRouter
40 | (\_ _ -> Router.continue)
41 | ( case _ of
42 | Router.Resolved _ route -> do
43 | newRoute <- Ref.modify (const route) value
44 | HS.notify listener newRoute
45 | _ -> pure unit
46 | )
47 | driver
48 | component <-
49 | React.component "Router" \_ -> React.do
50 | React.useEffectOnce do
51 | router.initialize
52 | pure React.empty
53 | pure
54 | ( { read: Ref.read value
55 | , emitter
56 | , navigate: router.navigate
57 | , redirect: router.redirect
58 | , reload: window >>= location >>= reload
59 | }
60 | /\ component unit
61 | )
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Config.js:
--------------------------------------------------------------------------------
1 | export const nodeEnv = process.env.NODE_ENV || "";
2 |
3 | export const deploymentUrl = process.env.DEPLOYMENT_URL || "";
4 |
5 | export const apiUrl = process.env.API_URL || "";
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Config.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Config where
2 |
3 | foreign import deploymentUrl :: String
4 |
5 | foreign import nodeEnv :: String
6 |
7 | foreign import apiUrl :: String
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Data/Log.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Data.Log
2 | ( LogReason(..)
3 | , message
4 | , reason
5 | , Log
6 | , mkLog
7 | ) where
8 |
9 | import Prelude
10 | import GenTypesDemo.Capability.Now (class Now, nowDateTime)
11 | import Data.DateTime (DateTime)
12 | import Data.Either (either)
13 | import Data.Foldable (fold)
14 | import Data.Formatter.DateTime (formatDateTime)
15 |
16 | data LogReason
17 | = Debug
18 | | Info
19 | | Warn
20 | | Error
21 |
22 | derive instance eqLogReason :: Eq LogReason
23 |
24 | derive instance ordLogReason :: Ord LogReason
25 |
26 | newtype Log
27 | = Log
28 | { reason :: LogReason
29 | , timestamp :: DateTime
30 | , message :: String
31 | }
32 |
33 | derive instance eqLog :: Eq Log
34 |
35 | message :: Log -> String
36 | message (Log { message: m }) = m
37 |
38 | reason :: Log -> LogReason
39 | reason (Log { reason: r }) = r
40 |
41 | mkLog :: forall m. Now m => LogReason -> String -> m Log
42 | mkLog logReason inputMessage = do
43 | now <- nowDateTime
44 | let
45 | -- Will produce a header like "{DEBUG: 2018-10-25 11:25:29 AM]\nMessage contents..."
46 | headerWith start = fold [ "[", start, ": ", formatTimestamp now, "]\n", inputMessage ]
47 |
48 | -- Writes the header with the correct log reason
49 | formattedLog =
50 | headerWith case logReason of
51 | Debug -> "DEBUG"
52 | Info -> "INFO"
53 | Warn -> "WARNING"
54 | Error -> "ERROR"
55 | pure $ Log { reason: logReason, timestamp: now, message: formattedLog }
56 | where
57 | -- Will format "2018-10-25 11:25:29 AM"
58 | formatTimestamp =
59 | either (const "(Failed to assign time)") identity
60 | <<< formatDateTime "YYYY-DD-MM hh:mm:ss a"
61 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Data/Route.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Data.Route where
2 |
3 | import Prelude hiding ((/))
4 |
5 | import Data.Generic.Rep (class Generic)
6 | import Routing.Duplex (RouteDuplex', default, root)
7 | import Routing.Duplex.Generic (noArgs, sum)
8 |
9 | data Route
10 | = Home
11 | | Error
12 |
13 | derive instance Generic Route _
14 |
15 | derive instance Eq Route
16 |
17 | routeCodec :: RouteDuplex' Route
18 | routeCodec =
19 | default Error
20 | $ root
21 | $ sum
22 | { "Home": noArgs
23 | , "Error": noArgs
24 | }
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Page/Home.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Page.Home where
2 |
3 | import Prelude
4 | import Prelude
5 |
6 | import Control.Monad.State (get, modify_)
7 | import Data.Array as Array
8 | import Data.Array.NonEmpty (NonEmptyArray)
9 | import Data.Array.NonEmpty as NE
10 | import Data.Array.NonEmpty as NonEmpty
11 | import Data.Either (Either(..))
12 | import Data.Function.Uncurried (mkFn2)
13 | import Data.List as List
14 | import Data.Map (Map)
15 | import Data.Map as Map
16 | import Data.Maybe (Maybe(..), fromMaybe)
17 | import Data.Newtype (unwrap)
18 | import Data.Tuple (fst)
19 | import Data.Tuple.Nested (type (/\), (/\))
20 | import Data.UUID.Argonaut as UUID
21 | import Debug (traceM)
22 | import Effect.Class (class MonadEffect, liftEffect)
23 | import Effect.Class.Console (log)
24 | import Effect.Uncurried (mkEffectFn1, mkEffectFn2)
25 | import GenTypesDemo.API.Error (APIError(..), printAPIError)
26 | import GenTypesDemo.API.Types (CreateUserRequest(..), User(..), UserData(..), UserId(..), Username(..))
27 | import GenTypesDemo.Capability.Halo (class MonadHalo, component)
28 | import GenTypesDemo.Capability.Log (class LogMessages, logError)
29 | import GenTypesDemo.Capability.Now (class Now)
30 | import GenTypesDemo.Capability.Users (class MonadUsers, deleteUser, listUsers, newUser)
31 | import GenTypesDemo.Component.NewUserRow (mkNewUserRow)
32 | import GenTypesDemo.Config as Config
33 | import Network.RemoteData (RemoteData)
34 | import Network.RemoteData as RemoteData
35 | import React.Basic.DOM as R
36 | import React.Basic.DOM.Events (targetValue)
37 | import React.Basic.Events (handler, handler_)
38 | import React.Basic.Hooks as React
39 | import React.Halo (HaloM)
40 | import React.Halo as Halo
41 | import Web.HTML.HTMLInputElement (placeholder)
42 |
43 | type Props
44 | = {}
45 |
46 | type State
47 | = { usersR :: RemoteData APIError (Array User)
48 | }
49 |
50 | data Action
51 | = Initialize
52 | | AddUser CreateUserRequest
53 | | DeleteUser UserId
54 |
55 | mkHomePage ::
56 | forall m.
57 | MonadEffect m =>
58 | MonadUsers m =>
59 | Now m =>
60 | LogMessages m =>
61 | MonadHalo m =>
62 | m (Props -> React.JSX)
63 | mkHomePage = do
64 | newUserRow <- mkNewUserRow
65 | component "HomePage" { initialState, eval, render: render newUserRow }
66 | where
67 | initialState _ =
68 | { usersR: RemoteData.NotAsked
69 | }
70 |
71 | eval =
72 | Halo.mkEval Halo.defaultEval
73 | { onInitialize = \_ -> Just Initialize
74 | , onAction = handleAction
75 | }
76 |
77 | handleAction :: Action -> HaloM Props State Action m Unit
78 | handleAction a = case a of
79 | Initialize -> do
80 | modify_ _ { usersR = RemoteData.Loading }
81 | usersR <- listUsers
82 | modify_ _ { usersR = RemoteData.fromEither usersR }
83 |
84 | pure unit
85 | AddUser newUserRequest -> do
86 | result <- newUser newUserRequest
87 | case result of
88 | Right u ->
89 | modify_
90 | $ \currentState ->
91 | let
92 | updatedUsers = (\users -> users <> [ u ]) <$> currentState.usersR
93 | in
94 | currentState { usersR = updatedUsers }
95 | Left err -> do
96 | traceM err
97 | logError "Could not add a new user."
98 | DeleteUser uId -> do
99 | result <- deleteUser uId
100 | case result of
101 | Right _ ->
102 | modify_
103 | $ \currentState ->
104 | let
105 | updatedUsers = Array.filter (\(User { id }) -> id /= uId) <$> currentState.usersR
106 | in
107 | currentState { usersR = updatedUsers }
108 | Left _err -> do
109 | logError "Could not delete user."
110 | pure unit
111 |
112 | render newUserRow { send, state: { usersR } } =
113 | R.section
114 | { className: "w-full h-screen bg-blue-50 flex flex-col items-center justify-center"
115 | , children:
116 | [ case usersR of
117 | RemoteData.Success users ->
118 | React.fragment
119 | [ R.table
120 | { className: "table-auto border bg-white border-blue-100 rounded-lg border-separate"
121 | , children:
122 | [ R.thead
123 | { children:
124 | [ R.tr
125 | { children:
126 | [ headerEl "User Id"
127 | , headerEl "Username"
128 | , headerEl "Email"
129 | , headerEl "Created At"
130 | , headerEl "Actions"
131 | ]
132 | }
133 | ]
134 | }
135 | , R.tbody
136 | { children: map toUserRow users
137 | }
138 | ]
139 | }
140 | , newUserRow { onSubmit: send <<< AddUser }
141 | ]
142 | RemoteData.Loading -> message "Loading stuff..."
143 | RemoteData.Failure err -> message $ "Error! Make sure the API is running on " <> Config.apiUrl <> "."
144 | RemoteData.NotAsked -> message "Preparing the world..."
145 | ]
146 | }
147 | where
148 | message m =
149 | R.section
150 | { className: "rounded-lg bg-white p-4"
151 | , children:
152 | [ R.text m
153 | ]
154 | }
155 |
156 | toUserRow (User { id, info: (UserData { created, email, username }) }) =
157 | R.tr
158 | { className: ""
159 | , children:
160 | [ cell (UUID.toString <<< unwrap $ id)
161 | , cell (unwrap username)
162 | , cell (show email)
163 | , cell (show <<< unwrap $ created)
164 | , actions id
165 | ]
166 | }
167 |
168 | actions id =
169 | R.td
170 | { className: ""
171 | , children: [ delete ]
172 | }
173 | where
174 | delete =
175 | R.button
176 | { className: "p-2 text-white bg-red-4 rounded-md"
177 | , onClick: handler_ (send $ DeleteUser id)
178 | , children: [ R.text "Delete" ]
179 | }
180 |
181 | cell t =
182 | R.td
183 | { className: "p-6 text-gray-9"
184 | , children:
185 | [ R.text t
186 | ]
187 | }
188 |
189 | headerEl t =
190 | R.th
191 | { className: "p-6 text-gray-9 font-bold"
192 | , children: [ R.text t ]
193 | }
194 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Root.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Root where
2 |
3 | import Prelude
4 |
5 | import Control.Monad.State (modify_)
6 | import Data.Maybe (Maybe(..))
7 | import Data.Tuple.Nested (type (/\), (/\))
8 | import Effect.Aff.Class (class MonadAff)
9 | import Effect.Class (liftEffect)
10 | import Effect.Class.Console (log)
11 | import Effect.Uncurried (runEffectFn1)
12 | import Foreign.Toast (toastContainer)
13 | import GenTypesDemo.Capability.Global (class MonadGlobal)
14 | import GenTypesDemo.Capability.Halo (class MonadHalo, component)
15 | import GenTypesDemo.Capability.Log (class LogMessages, logDebug, logInfo)
16 | import GenTypesDemo.Capability.Now (class Now)
17 | import GenTypesDemo.Capability.Routing (class MonadRouting, navigate)
18 | import GenTypesDemo.Capability.Routing as Routing
19 | import GenTypesDemo.Capability.Users (class MonadUsers)
20 | import GenTypesDemo.Component.GlobalContext (mkGlobalContext)
21 | import GenTypesDemo.Config as Config
22 | import GenTypesDemo.Data.Route (Route(..))
23 | import GenTypesDemo.Page.Home (mkHomePage)
24 | import React.Basic.DOM as R
25 | import React.Basic.Hooks as React
26 | import React.Halo as Halo
27 |
28 | data Action
29 | = Initialize
30 | | UpdateRoute Route
31 | | Navigate Route
32 |
33 | type Props
34 | = {}
35 |
36 | mkRoot ::
37 | forall m.
38 | MonadAff m =>
39 | MonadGlobal m =>
40 | MonadRouting m =>
41 | MonadHalo m =>
42 | MonadUsers m =>
43 | Now m =>
44 | LogMessages m =>
45 | m (Props -> React.JSX)
46 | mkRoot = do
47 | render <- mkRender
48 | component "Root" { initialState, eval, render }
49 | where
50 | initialState _ =
51 | { route: Error
52 | }
53 |
54 | eval =
55 | Halo.mkEval Halo.defaultEval
56 | { onInitialize = \_ -> Just Initialize
57 | , onAction = handleAction
58 | }
59 |
60 | handleAction = case _ of
61 | Initialize -> do
62 | -- routing
63 | handleAction <<< UpdateRoute =<< Routing.read
64 | Routing.subscribe UpdateRoute
65 | UpdateRoute route -> do
66 | modify_ _ { route = route }
67 | Navigate route -> do
68 | Routing.navigate route
69 |
70 | mkRender = do
71 | homePage <- mkHomePage
72 | globalContext <- mkGlobalContext
73 | pure
74 | $ \{ state } ->
75 | let
76 | contents = case state.route of
77 | Home -> homePage {}
78 | Error -> homePage {}
79 | in
80 | React.fragment
81 | [ globalContext unit
82 | , toastContainer
83 | , contents
84 | ]
85 |
--------------------------------------------------------------------------------
/client/src/GenTypesDemo/Utilities/Email.purs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.Utilities.Email (Email, mkEmail) where
2 |
3 | import Prelude
4 |
5 | import Data.Argonaut (JsonDecodeError(..), caseJsonString, encodeJson, fromString)
6 | import Data.Argonaut.Decode (class DecodeJson)
7 | import Data.Argonaut.Encode (class EncodeJson)
8 | import Data.Either (Either(..))
9 | import Data.Maybe (Maybe(..))
10 | import Text.Email.Parser (EmailAddress)
11 | import Text.Email.Parser as Email
12 | import Text.Email.Validate (emailAddress)
13 |
14 | newtype Email = Email EmailAddress
15 |
16 | mkEmail :: String -> Maybe Email
17 | mkEmail = map Email <<< emailAddress
18 |
19 | instance Show Email where
20 | show (Email email) = Email.toString email
21 |
22 | derive instance Eq Email
23 |
24 | instance EncodeJson Email where
25 | encodeJson (Email email) = encodeJson <<< Email.toString $ email
26 |
27 | instance DecodeJson Email where
28 | decodeJson = caseJsonString (Left $ TypeMismatch "string") $ \strValue ->
29 | case emailAddress strValue of
30 | Just validEmail -> Right (Email validEmail)
31 | Nothing -> Left $ UnexpectedValue $ fromString $ strValue <> " is not a valid email."
--------------------------------------------------------------------------------
/client/src/Main.purs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Prelude
4 | import Data.Argonaut (encodeJson, stringify)
5 | import Data.Argonaut.Decode (decodeJson, parseJson)
6 | import Data.Array (notElem, (:))
7 | import Data.Array as Array
8 | import Data.Either (Either(..))
9 | import Data.Map as Map
10 | import Data.Maybe (Maybe(..))
11 | import Data.Tuple.Nested ((/\))
12 | import Debug (traceM)
13 | import Effect (Effect)
14 | import Effect.Aff (launchAff_)
15 | import Effect.Class (liftEffect)
16 | import Effect.Class.Console (log)
17 | import Effect.Ref as Ref
18 | import Effect.Uncurried (mkEffectFn1, runEffectFn1, runEffectFn2)
19 | import GenTypesDemo.AppM (LogLevel(..), runAppM)
20 | import GenTypesDemo.Capability.Global (GlobalIO)
21 | import GenTypesDemo.Component.Routing as Routing
22 | import GenTypesDemo.Config as Config
23 | import GenTypesDemo.Root as Root
24 | import Halogen.Subscription as HS
25 | import Network.RemoteData as RemoteData
26 | import React.Basic.DOM as R
27 | import React.Basic.Hooks as R
28 | import React.Basic.Hooks as React
29 | import Web.DOM.NonElementParentNode (getElementById)
30 | import Web.HTML (window)
31 | import Web.HTML.HTMLDocument (toNonElementParentNode)
32 | import Web.HTML.History (pushState)
33 | import Web.HTML.Location (setHref)
34 | import Web.HTML.Window (document, history, localStorage, location)
35 | import Web.Storage.Storage (getItem, setItem)
36 |
37 | main :: Effect Unit
38 | main = do
39 | rootMay <- getElementById "root" =<< (map toNonElementParentNode $ document =<< window)
40 | case rootMay of
41 | Just root -> do
42 | routing /\ routingManager <- Routing.mkRoutingManager
43 | let
44 | logLevel = case Config.nodeEnv of
45 | "production" -> Prod
46 | "development" -> Dev
47 | _ -> Dev
48 | globalIO <- mkGlobalIO
49 | launchAff_
50 | $ do
51 | rootComponent <- runAppM { routing, logLevel, globalIO } Root.mkRoot
52 | mainComponent <-
53 | liftEffect
54 | $ React.component "Main"
55 | $ \_ -> React.do
56 | pure
57 | $ R.fragment
58 | [ routingManager
59 | , rootComponent {}
60 | ]
61 | liftEffect
62 | $ R.render (mainComponent unit) root
63 | Nothing -> log "No root element."
64 |
65 | mkGlobalIO :: Effect GlobalIO
66 | mkGlobalIO = create
67 | where
68 | create = do
69 | { emitter: actionsEmitter, listener: actionsListener } <- HS.create
70 | { emitter: eventsEmitter, listener: eventsListener } <- HS.create
71 | pure
72 | { eventsEmitter
73 | , eventsListener
74 | , actionsEmitter
75 | , actionsListener
76 | }
77 |
--------------------------------------------------------------------------------
/client/src/ServerAPI.purs:
--------------------------------------------------------------------------------
1 | -- File auto generated by servant-purescript! --
2 | module ServerAPI where
3 |
4 | import Prelude
5 |
6 | import Affjax.RequestHeader (RequestHeader(..))
7 | import Data.Argonaut (Json, JsonDecodeError)
8 | import Data.Argonaut.Decode.Aeson (($\>), (*\>), (\>))
9 | import Data.Argonaut.Encode.Aeson ((>$<), (>/\<))
10 | import Data.Array (catMaybes)
11 | import Data.Either (Either(..))
12 | import Data.Foldable (fold)
13 | import Data.HTTP.Method (Method(..))
14 | import Data.Maybe (Maybe(..))
15 | import Data.Tuple (Tuple)
16 | import GenTypesDemo.API.Auth (AuthorizationHeader)
17 | import GenTypesDemo.API.Types (CreateUserRequest, UpdateUserRequest, User, UserId)
18 | import Servant.PureScript (AjaxError, class MonadAjax, flagQueryPairs, paramListQueryPairs, paramQueryPairs, request, toHeader, toPathSegment)
19 | import URI (RelativePart(..), RelativeRef(..))
20 | import Data.Argonaut.Decode.Aeson as D
21 | import Data.Argonaut.Encode.Aeson as E
22 |
23 | data Api = Api
24 |
25 | getUsers ::
26 | forall m.
27 | MonadAjax Api m =>
28 | m (Either (AjaxError JsonDecodeError Json) (Array User))
29 | getUsers =
30 | request Api req
31 | where
32 | req = { method, uri, headers, content, encode, decode }
33 | method = Left GET
34 | uri = RelativeRef relativePart query Nothing
35 | headers = catMaybes
36 | [
37 | ]
38 | content = Nothing
39 | encode = E.encode encoder
40 | decode = D.decode decoder
41 | encoder = E.null
42 | decoder = D.value
43 | relativePart = RelativePartNoAuth $ Just
44 | [ "users"
45 | ]
46 | query = Nothing
47 |
48 | getUserByUserId ::
49 | forall m.
50 | MonadAjax Api m =>
51 | UserId ->
52 | m (Either (AjaxError JsonDecodeError Json) User)
53 | getUserByUserId userId =
54 | request Api req
55 | where
56 | req = { method, uri, headers, content, encode, decode }
57 | method = Left GET
58 | uri = RelativeRef relativePart query Nothing
59 | headers = catMaybes
60 | [
61 | ]
62 | content = Nothing
63 | encode = E.encode encoder
64 | decode = D.decode decoder
65 | encoder = E.null
66 | decoder = D.value
67 | relativePart = RelativePartNoAuth $ Just
68 | [ "user"
69 | , toPathSegment userId
70 | ]
71 | query = Nothing
72 |
73 | postUser ::
74 | forall m.
75 | MonadAjax Api m =>
76 | CreateUserRequest ->
77 | m (Either (AjaxError JsonDecodeError Json) User)
78 | postUser reqBody =
79 | request Api req
80 | where
81 | req = { method, uri, headers, content, encode, decode }
82 | method = Left POST
83 | uri = RelativeRef relativePart query Nothing
84 | headers = catMaybes
85 | [
86 | ]
87 | content = Just reqBody
88 | encode = E.encode encoder
89 | decode = D.decode decoder
90 | encoder = E.value
91 | decoder = D.value
92 | relativePart = RelativePartNoAuth $ Just
93 | [ "user"
94 | ]
95 | query = Nothing
96 |
97 | putUserByUserId ::
98 | forall m.
99 | MonadAjax Api m =>
100 | UpdateUserRequest ->
101 | UserId ->
102 | m (Either (AjaxError JsonDecodeError Json) Unit)
103 | putUserByUserId reqBody userId =
104 | request Api req
105 | where
106 | req = { method, uri, headers, content, encode, decode }
107 | method = Left PUT
108 | uri = RelativeRef relativePart query Nothing
109 | headers = catMaybes
110 | [
111 | ]
112 | content = Just reqBody
113 | encode = E.encode encoder
114 | decode = D.decode decoder
115 | encoder = E.value
116 | decoder = D.unit
117 | relativePart = RelativePartNoAuth $ Just
118 | [ "user"
119 | , toPathSegment userId
120 | ]
121 | query = Nothing
122 |
123 | deleteUserByUserId ::
124 | forall m.
125 | MonadAjax Api m =>
126 | Maybe AuthorizationHeader ->
127 | UserId ->
128 | m (Either (AjaxError JsonDecodeError Json) Unit)
129 | deleteUserByUserId authorization userId =
130 | request Api req
131 | where
132 | req = { method, uri, headers, content, encode, decode }
133 | method = Left DELETE
134 | uri = RelativeRef relativePart query Nothing
135 | headers = catMaybes
136 | [ RequestHeader "Authorization" <<< toHeader <$> authorization
137 | ]
138 | content = Nothing
139 | encode = E.encode encoder
140 | decode = D.decode decoder
141 | encoder = E.null
142 | decoder = D.unit
143 | relativePart = RelativePartNoAuth $ Just
144 | [ "user"
145 | , toPathSegment userId
146 | ]
147 | query = Nothing
148 |
--------------------------------------------------------------------------------
/client/src/input.css:
--------------------------------------------------------------------------------
1 | @tailwind base;
2 | @tailwind components;
3 | @tailwind utilities;
4 |
5 | body {
6 | font-family: "Inter", sans-serif;
7 | }
8 |
9 | html, body {
10 | @apply min-h-screen m-0
11 | }
12 |
13 | #root {
14 | @apply min-h-screen h-full
15 | }
--------------------------------------------------------------------------------
/client/src/styles.css:
--------------------------------------------------------------------------------
1 | /*
2 | ! tailwindcss v3.1.6 | MIT License | https://tailwindcss.com
3 | */
4 |
5 | /*
6 | 1. Prevent padding and border from affecting element width. (https://github.com/mozdevs/cssremedy/issues/4)
7 | 2. Allow adding a border to an element by just adding a border-width. (https://github.com/tailwindcss/tailwindcss/pull/116)
8 | */
9 |
10 | *,
11 | ::before,
12 | ::after {
13 | box-sizing: border-box;
14 | /* 1 */
15 | border-width: 0;
16 | /* 2 */
17 | border-style: solid;
18 | /* 2 */
19 | border-color: #e5e7eb;
20 | /* 2 */
21 | }
22 |
23 | ::before,
24 | ::after {
25 | --tw-content: '';
26 | }
27 |
28 | /*
29 | 1. Use a consistent sensible line-height in all browsers.
30 | 2. Prevent adjustments of font size after orientation changes in iOS.
31 | 3. Use a more readable tab size.
32 | 4. Use the user's configured `sans` font-family by default.
33 | */
34 |
35 | html {
36 | line-height: 1.5;
37 | /* 1 */
38 | -webkit-text-size-adjust: 100%;
39 | /* 2 */
40 | /* 3 */
41 | tab-size: 4;
42 | /* 3 */
43 | font-family: ui-sans-serif, system-ui, -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, "Helvetica Neue", Arial, "Noto Sans", sans-serif, "Apple Color Emoji", "Segoe UI Emoji", "Segoe UI Symbol", "Noto Color Emoji";
44 | /* 4 */
45 | }
46 |
47 | /*
48 | 1. Remove the margin in all browsers.
49 | 2. Inherit line-height from `html` so users can set them as a class directly on the `html` element.
50 | */
51 |
52 | body {
53 | margin: 0;
54 | /* 1 */
55 | line-height: inherit;
56 | /* 2 */
57 | }
58 |
59 | /*
60 | 1. Add the correct height in Firefox.
61 | 2. Correct the inheritance of border color in Firefox. (https://bugzilla.mozilla.org/show_bug.cgi?id=190655)
62 | 3. Ensure horizontal rules are visible by default.
63 | */
64 |
65 | hr {
66 | height: 0;
67 | /* 1 */
68 | color: inherit;
69 | /* 2 */
70 | border-top-width: 1px;
71 | /* 3 */
72 | }
73 |
74 | /*
75 | Add the correct text decoration in Chrome, Edge, and Safari.
76 | */
77 |
78 | abbr:where([title]) {
79 | -webkit-text-decoration: underline dotted;
80 | text-decoration: underline dotted;
81 | }
82 |
83 | /*
84 | Remove the default font size and weight for headings.
85 | */
86 |
87 | h1,
88 | h2,
89 | h3,
90 | h4,
91 | h5,
92 | h6 {
93 | font-size: inherit;
94 | font-weight: inherit;
95 | }
96 |
97 | /*
98 | Reset links to optimize for opt-in styling instead of opt-out.
99 | */
100 |
101 | a {
102 | color: inherit;
103 | text-decoration: inherit;
104 | }
105 |
106 | /*
107 | Add the correct font weight in Edge and Safari.
108 | */
109 |
110 | b,
111 | strong {
112 | font-weight: bolder;
113 | }
114 |
115 | /*
116 | 1. Use the user's configured `mono` font family by default.
117 | 2. Correct the odd `em` font sizing in all browsers.
118 | */
119 |
120 | code,
121 | kbd,
122 | samp,
123 | pre {
124 | font-family: ui-monospace, SFMono-Regular, Menlo, Monaco, Consolas, "Liberation Mono", "Courier New", monospace;
125 | /* 1 */
126 | font-size: 1em;
127 | /* 2 */
128 | }
129 |
130 | /*
131 | Add the correct font size in all browsers.
132 | */
133 |
134 | small {
135 | font-size: 80%;
136 | }
137 |
138 | /*
139 | Prevent `sub` and `sup` elements from affecting the line height in all browsers.
140 | */
141 |
142 | sub,
143 | sup {
144 | font-size: 75%;
145 | line-height: 0;
146 | position: relative;
147 | vertical-align: baseline;
148 | }
149 |
150 | sub {
151 | bottom: -0.25em;
152 | }
153 |
154 | sup {
155 | top: -0.5em;
156 | }
157 |
158 | /*
159 | 1. Remove text indentation from table contents in Chrome and Safari. (https://bugs.chromium.org/p/chromium/issues/detail?id=999088, https://bugs.webkit.org/show_bug.cgi?id=201297)
160 | 2. Correct table border color inheritance in all Chrome and Safari. (https://bugs.chromium.org/p/chromium/issues/detail?id=935729, https://bugs.webkit.org/show_bug.cgi?id=195016)
161 | 3. Remove gaps between table borders by default.
162 | */
163 |
164 | table {
165 | text-indent: 0;
166 | /* 1 */
167 | border-color: inherit;
168 | /* 2 */
169 | border-collapse: collapse;
170 | /* 3 */
171 | }
172 |
173 | /*
174 | 1. Change the font styles in all browsers.
175 | 2. Remove the margin in Firefox and Safari.
176 | 3. Remove default padding in all browsers.
177 | */
178 |
179 | button,
180 | input,
181 | optgroup,
182 | select,
183 | textarea {
184 | font-family: inherit;
185 | /* 1 */
186 | font-size: 100%;
187 | /* 1 */
188 | font-weight: inherit;
189 | /* 1 */
190 | line-height: inherit;
191 | /* 1 */
192 | color: inherit;
193 | /* 1 */
194 | margin: 0;
195 | /* 2 */
196 | padding: 0;
197 | /* 3 */
198 | }
199 |
200 | /*
201 | Remove the inheritance of text transform in Edge and Firefox.
202 | */
203 |
204 | button,
205 | select {
206 | text-transform: none;
207 | }
208 |
209 | /*
210 | 1. Correct the inability to style clickable types in iOS and Safari.
211 | 2. Remove default button styles.
212 | */
213 |
214 | button,
215 | [type='button'],
216 | [type='reset'],
217 | [type='submit'] {
218 | -webkit-appearance: button;
219 | /* 1 */
220 | background-color: transparent;
221 | /* 2 */
222 | background-image: none;
223 | /* 2 */
224 | }
225 |
226 | /*
227 | Use the modern Firefox focus style for all focusable elements.
228 | */
229 |
230 | :-moz-focusring {
231 | outline: auto;
232 | }
233 |
234 | /*
235 | Remove the additional `:invalid` styles in Firefox. (https://github.com/mozilla/gecko-dev/blob/2f9eacd9d3d995c937b4251a5557d95d494c9be1/layout/style/res/forms.css#L728-L737)
236 | */
237 |
238 | :-moz-ui-invalid {
239 | box-shadow: none;
240 | }
241 |
242 | /*
243 | Add the correct vertical alignment in Chrome and Firefox.
244 | */
245 |
246 | progress {
247 | vertical-align: baseline;
248 | }
249 |
250 | /*
251 | Correct the cursor style of increment and decrement buttons in Safari.
252 | */
253 |
254 | ::-webkit-inner-spin-button,
255 | ::-webkit-outer-spin-button {
256 | height: auto;
257 | }
258 |
259 | /*
260 | 1. Correct the odd appearance in Chrome and Safari.
261 | 2. Correct the outline style in Safari.
262 | */
263 |
264 | [type='search'] {
265 | -webkit-appearance: textfield;
266 | /* 1 */
267 | outline-offset: -2px;
268 | /* 2 */
269 | }
270 |
271 | /*
272 | Remove the inner padding in Chrome and Safari on macOS.
273 | */
274 |
275 | ::-webkit-search-decoration {
276 | -webkit-appearance: none;
277 | }
278 |
279 | /*
280 | 1. Correct the inability to style clickable types in iOS and Safari.
281 | 2. Change font properties to `inherit` in Safari.
282 | */
283 |
284 | ::-webkit-file-upload-button {
285 | -webkit-appearance: button;
286 | /* 1 */
287 | font: inherit;
288 | /* 2 */
289 | }
290 |
291 | /*
292 | Add the correct display in Chrome and Safari.
293 | */
294 |
295 | summary {
296 | display: list-item;
297 | }
298 |
299 | /*
300 | Removes the default spacing and border for appropriate elements.
301 | */
302 |
303 | blockquote,
304 | dl,
305 | dd,
306 | h1,
307 | h2,
308 | h3,
309 | h4,
310 | h5,
311 | h6,
312 | hr,
313 | figure,
314 | p,
315 | pre {
316 | margin: 0;
317 | }
318 |
319 | fieldset {
320 | margin: 0;
321 | padding: 0;
322 | }
323 |
324 | legend {
325 | padding: 0;
326 | }
327 |
328 | ol,
329 | ul,
330 | menu {
331 | list-style: none;
332 | margin: 0;
333 | padding: 0;
334 | }
335 |
336 | /*
337 | Prevent resizing textareas horizontally by default.
338 | */
339 |
340 | textarea {
341 | resize: vertical;
342 | }
343 |
344 | /*
345 | 1. Reset the default placeholder opacity in Firefox. (https://github.com/tailwindlabs/tailwindcss/issues/3300)
346 | 2. Set the default placeholder color to the user's configured gray 400 color.
347 | */
348 |
349 | input::-webkit-input-placeholder, textarea::-webkit-input-placeholder {
350 | opacity: 1;
351 | /* 1 */
352 | color: #9ca3af;
353 | /* 2 */
354 | }
355 |
356 | input::placeholder,
357 | textarea::placeholder {
358 | opacity: 1;
359 | /* 1 */
360 | color: #9ca3af;
361 | /* 2 */
362 | }
363 |
364 | /*
365 | Set the default cursor for buttons.
366 | */
367 |
368 | button,
369 | [role="button"] {
370 | cursor: pointer;
371 | }
372 |
373 | /*
374 | Make sure disabled buttons don't get the pointer cursor.
375 | */
376 |
377 | :disabled {
378 | cursor: default;
379 | }
380 |
381 | /*
382 | 1. Make replaced elements `display: block` by default. (https://github.com/mozdevs/cssremedy/issues/14)
383 | 2. Add `vertical-align: middle` to align replaced elements more sensibly by default. (https://github.com/jensimmons/cssremedy/issues/14#issuecomment-634934210)
384 | This can trigger a poorly considered lint error in some tools but is included by design.
385 | */
386 |
387 | img,
388 | svg,
389 | video,
390 | canvas,
391 | audio,
392 | iframe,
393 | embed,
394 | object {
395 | display: block;
396 | /* 1 */
397 | vertical-align: middle;
398 | /* 2 */
399 | }
400 |
401 | /*
402 | Constrain images and videos to the parent width and preserve their intrinsic aspect ratio. (https://github.com/mozdevs/cssremedy/issues/14)
403 | */
404 |
405 | img,
406 | video {
407 | max-width: 100%;
408 | height: auto;
409 | }
410 |
411 | *, ::before, ::after {
412 | --tw-border-spacing-x: 0;
413 | --tw-border-spacing-y: 0;
414 | --tw-translate-x: 0;
415 | --tw-translate-y: 0;
416 | --tw-rotate: 0;
417 | --tw-skew-x: 0;
418 | --tw-skew-y: 0;
419 | --tw-scale-x: 1;
420 | --tw-scale-y: 1;
421 | --tw-pan-x: ;
422 | --tw-pan-y: ;
423 | --tw-pinch-zoom: ;
424 | --tw-scroll-snap-strictness: proximity;
425 | --tw-ordinal: ;
426 | --tw-slashed-zero: ;
427 | --tw-numeric-figure: ;
428 | --tw-numeric-spacing: ;
429 | --tw-numeric-fraction: ;
430 | --tw-ring-inset: ;
431 | --tw-ring-offset-width: 0px;
432 | --tw-ring-offset-color: #fff;
433 | --tw-ring-color: rgb(59 130 246 / 0.5);
434 | --tw-ring-offset-shadow: 0 0 #0000;
435 | --tw-ring-shadow: 0 0 #0000;
436 | --tw-shadow: 0 0 #0000;
437 | --tw-shadow-colored: 0 0 #0000;
438 | --tw-blur: ;
439 | --tw-brightness: ;
440 | --tw-contrast: ;
441 | --tw-grayscale: ;
442 | --tw-hue-rotate: ;
443 | --tw-invert: ;
444 | --tw-saturate: ;
445 | --tw-sepia: ;
446 | --tw-drop-shadow: ;
447 | --tw-backdrop-blur: ;
448 | --tw-backdrop-brightness: ;
449 | --tw-backdrop-contrast: ;
450 | --tw-backdrop-grayscale: ;
451 | --tw-backdrop-hue-rotate: ;
452 | --tw-backdrop-invert: ;
453 | --tw-backdrop-opacity: ;
454 | --tw-backdrop-saturate: ;
455 | --tw-backdrop-sepia: ;
456 | }
457 |
458 | ::-webkit-backdrop {
459 | --tw-border-spacing-x: 0;
460 | --tw-border-spacing-y: 0;
461 | --tw-translate-x: 0;
462 | --tw-translate-y: 0;
463 | --tw-rotate: 0;
464 | --tw-skew-x: 0;
465 | --tw-skew-y: 0;
466 | --tw-scale-x: 1;
467 | --tw-scale-y: 1;
468 | --tw-pan-x: ;
469 | --tw-pan-y: ;
470 | --tw-pinch-zoom: ;
471 | --tw-scroll-snap-strictness: proximity;
472 | --tw-ordinal: ;
473 | --tw-slashed-zero: ;
474 | --tw-numeric-figure: ;
475 | --tw-numeric-spacing: ;
476 | --tw-numeric-fraction: ;
477 | --tw-ring-inset: ;
478 | --tw-ring-offset-width: 0px;
479 | --tw-ring-offset-color: #fff;
480 | --tw-ring-color: rgb(59 130 246 / 0.5);
481 | --tw-ring-offset-shadow: 0 0 #0000;
482 | --tw-ring-shadow: 0 0 #0000;
483 | --tw-shadow: 0 0 #0000;
484 | --tw-shadow-colored: 0 0 #0000;
485 | --tw-blur: ;
486 | --tw-brightness: ;
487 | --tw-contrast: ;
488 | --tw-grayscale: ;
489 | --tw-hue-rotate: ;
490 | --tw-invert: ;
491 | --tw-saturate: ;
492 | --tw-sepia: ;
493 | --tw-drop-shadow: ;
494 | --tw-backdrop-blur: ;
495 | --tw-backdrop-brightness: ;
496 | --tw-backdrop-contrast: ;
497 | --tw-backdrop-grayscale: ;
498 | --tw-backdrop-hue-rotate: ;
499 | --tw-backdrop-invert: ;
500 | --tw-backdrop-opacity: ;
501 | --tw-backdrop-saturate: ;
502 | --tw-backdrop-sepia: ;
503 | }
504 |
505 | ::backdrop {
506 | --tw-border-spacing-x: 0;
507 | --tw-border-spacing-y: 0;
508 | --tw-translate-x: 0;
509 | --tw-translate-y: 0;
510 | --tw-rotate: 0;
511 | --tw-skew-x: 0;
512 | --tw-skew-y: 0;
513 | --tw-scale-x: 1;
514 | --tw-scale-y: 1;
515 | --tw-pan-x: ;
516 | --tw-pan-y: ;
517 | --tw-pinch-zoom: ;
518 | --tw-scroll-snap-strictness: proximity;
519 | --tw-ordinal: ;
520 | --tw-slashed-zero: ;
521 | --tw-numeric-figure: ;
522 | --tw-numeric-spacing: ;
523 | --tw-numeric-fraction: ;
524 | --tw-ring-inset: ;
525 | --tw-ring-offset-width: 0px;
526 | --tw-ring-offset-color: #fff;
527 | --tw-ring-color: rgb(59 130 246 / 0.5);
528 | --tw-ring-offset-shadow: 0 0 #0000;
529 | --tw-ring-shadow: 0 0 #0000;
530 | --tw-shadow: 0 0 #0000;
531 | --tw-shadow-colored: 0 0 #0000;
532 | --tw-blur: ;
533 | --tw-brightness: ;
534 | --tw-contrast: ;
535 | --tw-grayscale: ;
536 | --tw-hue-rotate: ;
537 | --tw-invert: ;
538 | --tw-saturate: ;
539 | --tw-sepia: ;
540 | --tw-drop-shadow: ;
541 | --tw-backdrop-blur: ;
542 | --tw-backdrop-brightness: ;
543 | --tw-backdrop-contrast: ;
544 | --tw-backdrop-grayscale: ;
545 | --tw-backdrop-hue-rotate: ;
546 | --tw-backdrop-invert: ;
547 | --tw-backdrop-opacity: ;
548 | --tw-backdrop-saturate: ;
549 | --tw-backdrop-sepia: ;
550 | }
551 |
552 | .mt-8 {
553 | margin-top: 2rem;
554 | }
555 |
556 | .flex {
557 | display: flex;
558 | }
559 |
560 | .table {
561 | display: table;
562 | }
563 |
564 | .contents {
565 | display: contents;
566 | }
567 |
568 | .h-screen {
569 | height: 100vh;
570 | }
571 |
572 | .w-full {
573 | width: 100%;
574 | }
575 |
576 | .table-auto {
577 | table-layout: auto;
578 | }
579 |
580 | .border-separate {
581 | border-collapse: separate;
582 | }
583 |
584 | .flex-row {
585 | flex-direction: row;
586 | }
587 |
588 | .flex-col {
589 | flex-direction: column;
590 | }
591 |
592 | .items-center {
593 | align-items: center;
594 | }
595 |
596 | .justify-center {
597 | justify-content: center;
598 | }
599 |
600 | .space-x-4 > :not([hidden]) ~ :not([hidden]) {
601 | --tw-space-x-reverse: 0;
602 | margin-right: calc(1rem * var(--tw-space-x-reverse));
603 | margin-left: calc(1rem * calc(1 - var(--tw-space-x-reverse)));
604 | }
605 |
606 | .space-y-2 > :not([hidden]) ~ :not([hidden]) {
607 | --tw-space-y-reverse: 0;
608 | margin-top: calc(0.5rem * calc(1 - var(--tw-space-y-reverse)));
609 | margin-bottom: calc(0.5rem * var(--tw-space-y-reverse));
610 | }
611 |
612 | .space-y-4 > :not([hidden]) ~ :not([hidden]) {
613 | --tw-space-y-reverse: 0;
614 | margin-top: calc(1rem * calc(1 - var(--tw-space-y-reverse)));
615 | margin-bottom: calc(1rem * var(--tw-space-y-reverse));
616 | }
617 |
618 | .rounded-lg {
619 | border-radius: 0.5rem;
620 | }
621 |
622 | .rounded-md {
623 | border-radius: 0.375rem;
624 | }
625 |
626 | .border {
627 | border-width: 1px;
628 | }
629 |
630 | .border-slate-100 {
631 | --tw-border-opacity: 1;
632 | border-color: rgb(241 245 249 / var(--tw-border-opacity));
633 | }
634 |
635 | .border-blue-100 {
636 | --tw-border-opacity: 1;
637 | border-color: rgb(219 234 254 / var(--tw-border-opacity));
638 | }
639 |
640 | .border-blue-600 {
641 | --tw-border-opacity: 1;
642 | border-color: rgb(37 99 235 / var(--tw-border-opacity));
643 | }
644 |
645 | .bg-white {
646 | --tw-bg-opacity: 1;
647 | background-color: rgb(255 255 255 / var(--tw-bg-opacity));
648 | }
649 |
650 | .bg-gold-4 {
651 | --tw-bg-opacity: 1;
652 | background-color: rgb(255 214 102 / var(--tw-bg-opacity));
653 | }
654 |
655 | .bg-blue-50 {
656 | --tw-bg-opacity: 1;
657 | background-color: rgb(239 246 255 / var(--tw-bg-opacity));
658 | }
659 |
660 | .bg-red-4 {
661 | --tw-bg-opacity: 1;
662 | background-color: rgb(255 120 117 / var(--tw-bg-opacity));
663 | }
664 |
665 | .p-2 {
666 | padding: 0.5rem;
667 | }
668 |
669 | .p-6 {
670 | padding: 1.5rem;
671 | }
672 |
673 | .p-4 {
674 | padding: 1rem;
675 | }
676 |
677 | .font-bold {
678 | font-weight: 700;
679 | }
680 |
681 | .text-gray-9 {
682 | --tw-text-opacity: 1;
683 | color: rgb(38 38 38 / var(--tw-text-opacity));
684 | }
685 |
686 | .text-white {
687 | --tw-text-opacity: 1;
688 | color: rgb(255 255 255 / var(--tw-text-opacity));
689 | }
690 |
691 | .filter {
692 | -webkit-filter: var(--tw-blur) var(--tw-brightness) var(--tw-contrast) var(--tw-grayscale) var(--tw-hue-rotate) var(--tw-invert) var(--tw-saturate) var(--tw-sepia) var(--tw-drop-shadow);
693 | filter: var(--tw-blur) var(--tw-brightness) var(--tw-contrast) var(--tw-grayscale) var(--tw-hue-rotate) var(--tw-invert) var(--tw-saturate) var(--tw-sepia) var(--tw-drop-shadow);
694 | }
695 |
696 | body {
697 | font-family: "Inter", sans-serif;
698 | }
699 |
700 | html, body {
701 | margin: 0px;
702 | min-height: 100vh;
703 | }
704 |
705 | #root {
706 | height: 100%;
707 | min-height: 100vh;
708 | }
--------------------------------------------------------------------------------
/client/tailwind.config.js:
--------------------------------------------------------------------------------
1 | module.exports = {
2 | mode: "jit",
3 | content: ["./src/GenTypesDemo/**/*.purs", "./src/GenTypesDemo/**/*.js"],
4 | theme: {
5 | extend: {
6 | fontSize: {
7 | 'h1': '60px',
8 | 'h2': '35px',
9 | 'body': '16px',
10 | 'caption': '20px',
11 | 'subtext': '14px'
12 | },
13 | minWidth: {
14 | '24': '6rem',
15 | '28': '7rem',
16 | '32': '8rem',
17 | '36': '9rem',
18 | },
19 | maxWidth: {
20 | '8xl': '88rem'
21 | },
22 | minHeight: {
23 | '12': '2.5rem',
24 | '14': '3rem',
25 | '24': '6rem',
26 | '28': '7rem',
27 | '32': '8rem',
28 | '36': '9rem',
29 | },
30 | colors: {
31 | 'oceanic-green': '#86EFAC',
32 | 'oceanic-blue': '#3B82F6',
33 | 'oceanic-purple': '#9333EA',
34 | 'background-3': '#23232C',
35 | 'background-1': '#f0f2f5',
36 | 'background-2': '#001529',
37 | 'background-3': '#000c17',
38 | 'background-4': '#090100',
39 | 'gray-1': '#ffffff',
40 | 'gray-2': '#fcfcfc',
41 | 'gray-3': '#f5f5f5',
42 | 'gray-4': '#f0f0f0',
43 | 'gray-5': '#d9d9d9',
44 | 'gray-6': '#bfbfbf',
45 | 'gray-7': '#8c8c8c',
46 | 'gray-8': '#595959',
47 | 'gray-9': '#262626',
48 | 'gray-10': '#000000',
49 | 'blue-1': '#e6f7ff',
50 | 'blue-3': '#91d5ff',
51 | 'blue-4': '#69c0ff',
52 | 'blue-2': '#bae7ff',
53 | 'blue-5': '#40a9ff',
54 | 'blue-6': '#1890ff',
55 | 'blue-7': '#096dd9',
56 | 'blue-8': '#0050b3',
57 | 'blue-9': '#003a8c',
58 | 'blue-10': '#002766',
59 | 'red-1': '#fff1f0',
60 | 'red-2': '#ffccc7',
61 | 'red-3': '#ffa39e',
62 | 'red-5': '#ff4d4f',
63 | 'red-6': '#f5222d',
64 | 'red-7': '#cf1322',
65 | 'red-8': '#a8071a',
66 | 'red-9': '#820014',
67 | 'red-10': '#5c0011',
68 | 'red-4': '#ff7875',
69 | 'volcano-1': '#fff2e8',
70 | 'volcano-2': '#ffd8bf',
71 | 'volcano-3': '#ffbb96',
72 | 'volcano-4': '#ff9c6e',
73 | 'volcano-5': '#ff7a45',
74 | 'volcano-6': '#fa541c',
75 | 'volcano-7': '#d4380d',
76 | 'volcano-8': '#ad2102',
77 | 'volcano-9': '#871400',
78 | 'volcano-10': '#610b00',
79 | 'orange-1': '#fff7e6',
80 | 'orange-2': '#ffe7ba',
81 | 'orange-3': '#ffd591',
82 | 'orange-4': '#ffc069',
83 | 'orange-5': '#fa8c16',
84 | 'orange-6': '#fa8c16',
85 | 'orange-7': '#d46b08',
86 | 'orange-8': '#ad4e00',
87 | 'orange-9': '#873800',
88 | 'orange-10': '#612500',
89 | 'gold-1': '#fffbe6',
90 | 'gold-2': '#fff1b8',
91 | 'gold-3': '#ffe58f',
92 | 'gold-4': '#ffd666',
93 | 'gold-5': '#ffc53d',
94 | 'gold-6': '#faad14',
95 | 'gold-7': '#d48806',
96 | 'gold-8': '#ad6800',
97 | 'gold-9': '#874d00',
98 | 'gold-10': '#613400',
99 | 'yellow-1': '#feffe6',
100 | 'yellow-2': '#ffffb8',
101 | 'yellow-3': '#fffb8f',
102 | 'yellow-4': '#fff566',
103 | 'yellow-5': '#ffec3d',
104 | 'yellow-6': '#fadb14',
105 | 'yellow-7': '#d4b106',
106 | 'yellow-8': '#ad8b00',
107 | 'yellow-9': '#876800',
108 | 'yellow-10': '#614700',
109 | 'lime-1': '#fcffe6',
110 | 'lime-2': '#f4ffb8',
111 | 'lime-3': '#eaff8f',
112 | 'lime-4': '#d3f261',
113 | 'lime-5': '#bae637',
114 | 'lime-6': '#a0d911',
115 | 'lime-7': '#7cb305',
116 | 'lime-8': '#5b8c00',
117 | 'lime-9': '#3f6600',
118 | 'lime-10': '#254000',
119 | 'green-1': '#f6ffed',
120 | 'green-2': '#d9f7be',
121 | 'green-3': '#b7eb8f',
122 | 'green-4': '#95de64',
123 | 'green-5': '#73d13d',
124 | 'green-6': '#52c41a',
125 | 'green-7': '#389e0d',
126 | 'green-8': '#237804',
127 | 'green-9': '#135200',
128 | 'green-10': '#092b00',
129 | 'cyan-1': '#e6fffb',
130 | 'cyan-2': '#b5f5ec',
131 | 'cyan-3': '#87e8de',
132 | 'cyan-4': '#5cdbd3',
133 | 'cyan-5': '#36cfc9',
134 | 'cyan-6': '#13c2c2',
135 | 'cyan-7': '#08979c',
136 | 'cyan-8': '#006d75',
137 | 'cyan-9': '#00474f',
138 | 'cyan-10': '#002329',
139 | 'geekblue-1': '#f0f5ff',
140 | 'geekblue-2': '#d6e4ff',
141 | 'geekblue-3': '#adc6ff',
142 | 'geekblue-4': '#85a5ff',
143 | 'geekblue-5': '#597ef7',
144 | 'geekblue-6': '#2f54eb',
145 | 'geekblue-7': '#1d39c4',
146 | 'geekblue-8': '#10239e',
147 | 'geekblue-9': '#061178',
148 | 'geekblue-10': '#030852',
149 | 'purple-1': '#f9f0ff',
150 | 'purple-2': '#efdbff',
151 | 'purple-3': '#d3adf7',
152 | 'purple-4': '#b37feb',
153 | 'purple-5': '#9254de',
154 | 'purple-6': '#722ed1',
155 | 'purple-7': '#531dab',
156 | 'purple-8': '#391085',
157 | 'purple-9': '#22075e',
158 | 'purple-10': '#120338',
159 | 'magenta-1': '#fff0f6',
160 | 'magenta-2': '#ffd6e7',
161 | 'magenta-3': '#ffadd2',
162 | 'magenta-4': '#ff85c0',
163 | 'magenta-5': '#f759ab',
164 | 'magenta-6': '#eb2f96',
165 | 'magenta-7': '#c41d7f',
166 | 'magenta-8': '#9e1068',
167 | 'magenta-9': '#780650',
168 | 'magenta-10': '#520339'
169 | },
170 | boxShadow: {
171 | 'side': '-4px 0px 30px rgba(62, 60, 87, 0.1);',
172 | 'glowing': '0px 0px 15px rgba(0, 0, 0, 0.15)',
173 | 'bottom': '0px 4px 30px rgba(62, 60, 87, 0.05)',
174 | 'top': '0px 5px 30px rgba(62, 60, 87, 0.15)',
175 | 'left': '-4px 0px 16px rgba(0, 16, 48, 0.15)',
176 | 'top-lg': '-10px -4px 30px rgba(62, 60, 87, 0.05)'
177 | }
178 | },
179 | },
180 | plugins: [
181 | ],
182 | variants: {
183 | }
184 | };
--------------------------------------------------------------------------------
/client/test/Main.purs:
--------------------------------------------------------------------------------
1 | module Test.Main where
2 |
3 | import Prelude
4 |
5 | import Effect (Effect)
6 | import Effect.Class.Console (log)
7 |
8 | main :: Effect Unit
9 | main = do
10 | log "🍝"
11 | log "You should add some tests."
12 |
--------------------------------------------------------------------------------
/client/theme.js:
--------------------------------------------------------------------------------
1 | const theme = {
2 | colors:
3 | {
4 | 'Gray ':
5 | {
6 | 'gray-1': '#ffffff',
7 | 'gray-2': '#fcfcfc',
8 | 'gray-3': '#f5f5f5',
9 | 'gray-4': '#f0f0f0',
10 | 'gray-5': '#d9d9d9',
11 | 'gray-6': '#bfbfbf',
12 | 'gray-7': '#8c8c8c',
13 | 'gray-8': '#595959',
14 | 'gray-9': '#262626',
15 | 'gray-10': '#000000'
16 | },
17 | 'Daybreak Blue': { 'blue-1': '#e6f7ff', 'blue-3': '#91d5ff', 'blue-4': '#69c0ff'},
18 | 'Daybreak Blue ':
19 | {
20 | 'blue-2': '#bae7ff',
21 | 'blue-5': '#40a9ff',
22 | 'blue-6': '#1890ff',
23 | 'blue-7': '#096dd9',
24 | 'blue-8': '#0050b3',
25 | 'blue-9': '#003a8c',
26 | 'blue-10': '#002766'
27 | },
28 | 'Dust Red ':
29 | {
30 | 'red-1': '#fff1f0',
31 | 'red-2': '#ffccc7',
32 | 'red-3': '#ffa39e',
33 | 'red-5': '#ff4d4f',
34 | 'red-6': '#f5222d',
35 | 'red-7': '#cf1322',
36 | 'red-8': '#a8071a',
37 | 'red-9': '#820014',
38 | 'red-10': '#5c0011'
39 | },
40 | 'Dust Red': { 'red-4': '#ff7875'},
41 | 'Volcano ':
42 | {
43 | 'volcano-1': '#fff2e8',
44 | 'volcano-2': '#ffd8bf',
45 | 'volcano-3': '#ffbb96',
46 | 'volcano-4': '#ff9c6e',
47 | 'volcano-5': '#ff7a45',
48 | 'volcano-6': '#fa541c',
49 | 'volcano-7': '#d4380d',
50 | 'volcano-8': '#ad2102',
51 | 'volcano-9': '#871400',
52 | 'volcano-10': '#610b00'
53 | },
54 | 'Sunset Orange ':
55 | {
56 | 'orange-1': '#fff7e6',
57 | 'orange-2': '#ffe7ba',
58 | 'orange-3': '#ffd591',
59 | 'orange-4': '#ffc069',
60 | 'orange-5': '#fa8c16',
61 | 'orange-6': '#fa8c16',
62 | 'orange-7': '#d46b08',
63 | 'orange-8': '#ad4e00',
64 | 'orange-9': '#873800',
65 | 'orange-10': '#612500'
66 | },
67 | 'Calendula Gold ':
68 | {
69 | 'gold-1': '#fffbe6',
70 | 'gold-2': '#fff1b8',
71 | 'gold-3': '#ffe58f',
72 | 'gold-4': '#ffd666',
73 | 'gold-5': '#ffc53d',
74 | 'gold-6': '#faad14',
75 | 'gold-7': '#d48806',
76 | 'gold-8': '#ad6800',
77 | 'gold-9': '#874d00',
78 | 'gold-10': '#613400'
79 | },
80 | 'Sunrise Yellow ':
81 | {
82 | 'yellow-1': '#feffe6',
83 | 'yellow-2': '#ffffb8',
84 | 'yellow-3': '#fffb8f',
85 | 'yellow-4': '#fff566',
86 | 'yellow-5': '#ffec3d',
87 | 'yellow-6': '#fadb14',
88 | 'yellow-7': '#d4b106',
89 | 'yellow-8': '#ad8b00',
90 | 'yellow-9': '#876800',
91 | 'yellow-10': '#614700'
92 | },
93 | 'Lime ':
94 | {
95 | 'lime-1': '#fcffe6',
96 | 'lime-2': '#f4ffb8',
97 | 'lime-3': '#eaff8f',
98 | 'lime-4': '#d3f261',
99 | 'lime-5': '#bae637',
100 | 'lime-6': '#a0d911',
101 | 'lime-7': '#7cb305',
102 | 'lime-8': '#5b8c00',
103 | 'lime-9': '#3f6600',
104 | 'lime-10': '#254000'
105 | },
106 | 'Polar Green ':
107 | {
108 | 'green-1': '#f6ffed',
109 | 'green-2': '#d9f7be',
110 | 'green-3': '#b7eb8f',
111 | 'green-4': '#95de64',
112 | 'green-5': '#73d13d',
113 | 'green-6': '#52c41a',
114 | 'green-7': '#389e0d',
115 | 'green-8': '#237804',
116 | 'green-9': '#135200',
117 | 'green-10': '#092b00'
118 | },
119 | 'Cyan ':
120 | {
121 | 'cyan-1': '#e6fffb',
122 | 'cyan-2': '#b5f5ec',
123 | 'cyan-3': '#87e8de',
124 | 'cyan-4': '#5cdbd3',
125 | 'cyan-5': '#36cfc9',
126 | 'cyan-6': '#13c2c2',
127 | 'cyan-7': '#08979c',
128 | 'cyan-8': '#006d75',
129 | 'cyan-9': '#00474f',
130 | 'cyan-10': '#002329'
131 | },
132 | 'Geek Blue ':
133 | {
134 | 'geekblue-1': '#f0f5ff',
135 | 'geekblue-2': '#d6e4ff',
136 | 'geekblue-3': '#adc6ff',
137 | 'geekblue-4': '#85a5ff',
138 | 'geekblue-5': '#597ef7',
139 | 'geekblue-6': '#2f54eb',
140 | 'geekblue-7': '#1d39c4',
141 | 'geekblue-8': '#10239e',
142 | 'geekblue-9': '#061178',
143 | 'geekblue-10': '#030852'
144 | },
145 | 'Golden Purple ':
146 | {
147 | 'purple-1': '#f9f0ff',
148 | 'purple-2': '#efdbff',
149 | 'purple-3': '#d3adf7',
150 | 'purple-4': '#b37feb',
151 | 'purple-5': '#9254de',
152 | 'purple-6': '#722ed1',
153 | 'purple-7': '#531dab',
154 | 'purple-8': '#391085',
155 | 'purple-9': '#22075e',
156 | 'purple-10': '#120338'
157 | },
158 | 'Magenta ':
159 | {
160 | 'magenta-1': '#fff0f6',
161 | 'magenta-2': '#ffd6e7',
162 | 'magenta-3': '#ffadd2',
163 | 'magenta-4': '#ff85c0',
164 | 'magenta-5': '#f759ab',
165 | 'magenta-6': '#eb2f96',
166 | 'magenta-7': '#c41d7f',
167 | 'magenta-8': '#9e1068',
168 | 'magenta-9': '#780650',
169 | 'magenta-10': '#520339'
170 | },
171 | 'Extra ':
172 | {
173 | 'background-1': '#f0f2f5',
174 | 'background-2': '#001529',
175 | 'background-3': '#000c17',
176 | 'background-4': '#090100'
177 | }
178 | },
179 | fontSize:
180 | {
181 | xs: '0.75rem',
182 | sm: '0.875rem',
183 | base: '1rem',
184 | lg: '1.25rem',
185 | xl: '1.5rem',
186 | '2xl': '1.875rem',
187 | '3xl': '2.375rem',
188 | '4xl': '2.875rem',
189 | '5xl': '3.5rem',
190 | '6xl': '4rem'
191 | },
192 | fontFamily:
193 | {
194 | 'red-hat-display': 'Red Hat Display',
195 | 'open-sans': 'Open Sans'
196 | },
197 | boxShadow: { 'Panels / Elevation': '0px 3px 6px -4px rgba(0,0,0,0.12), 0px 6px 16px 0px rgba(0,0,0,0.08), 0px 9px 28px 8px rgba(0,0,0,0.05)'},
198 | borderRadius:
199 | {
200 | none: '0',
201 | xs: '0.125rem',
202 | sm: '0.1830359399318695rem',
203 | default: '0.1875rem',
204 | lg: '0.25rem',
205 | xl: '0.3125rem',
206 | '2xl': '0.3907355070114136rem',
207 | '3xl': '0.5rem',
208 | '4xl': '0.625rem',
209 | '5xl': '0.8125rem',
210 | '6xl': '0.875rem',
211 | '7xl': '1rem',
212 | '8xl': '1.25rem',
213 | '9xl': '1.306485652923584rem',
214 | '10xl': '1.5rem',
215 | '11xl': '1.875rem',
216 | '12xl': '3.125rem',
217 | '13xl': '6rem',
218 | full: '9999px'
219 | }
220 | };
--------------------------------------------------------------------------------
/demo.gif:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/dnikolovv/servant-purescript-codegen-example/5e5c8d81d76d07e73b67eadeae0bcd469adba8cb/demo.gif
--------------------------------------------------------------------------------
/server/.gitignore:
--------------------------------------------------------------------------------
1 | .stack-work/
2 | *~
3 | .vscode
4 |
--------------------------------------------------------------------------------
/server/ChangeLog.md:
--------------------------------------------------------------------------------
1 | # Changelog for gentypes-server
2 |
3 | ## Unreleased changes
4 |
--------------------------------------------------------------------------------
/server/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright Author name here (c) 2022
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 Author name here 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 |
--------------------------------------------------------------------------------
/server/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/server/app/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import GenTypesDemo.Run
4 | import RIO
5 |
6 | main :: IO ()
7 | main = run
8 |
--------------------------------------------------------------------------------
/server/codegen.sh:
--------------------------------------------------------------------------------
1 | stack run gentypes-codegen -- ../client/src
2 |
--------------------------------------------------------------------------------
/server/codegen/Main.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TypeApplications #-}
2 |
3 | module Main where
4 |
5 | import System.Environment
6 | import System.IO (print)
7 | import GenTypesDemo.API.CodeGen
8 | import RIO
9 | import RIO.List
10 |
11 | main :: IO ()
12 | main = do
13 | args <- getArgs
14 | case headMaybe args of
15 | Just path -> genPureScriptTypes path >> genServant path
16 | Nothing -> print @String "Missing arguments."
17 |
--------------------------------------------------------------------------------
/server/gentypes-server.cabal:
--------------------------------------------------------------------------------
1 | cabal-version: 1.12
2 |
3 | -- This file has been generated from package.yaml by hpack version 0.34.4.
4 | --
5 | -- see: https://github.com/sol/hpack
6 |
7 | name: gentypes-server
8 | version: 0.1.0.0
9 | description: Please see the README on GitHub at
10 | homepage: https://github.com/dnikolovv/gentypes-server#readme
11 | bug-reports: https://github.com/dnikolovv/gentypes-server/issues
12 | author: Dobromir Nikolov
13 | maintainer: example@example.com
14 | copyright: 2022 Dobromir Nikolov
15 | license: BSD3
16 | license-file: LICENSE
17 | build-type: Simple
18 |
19 | source-repository head
20 | type: git
21 | location: https://github.com/dnikolovv/gentypes-server
22 |
23 | library
24 | exposed-modules:
25 | GenTypesDemo.API.Auth
26 | GenTypesDemo.API.CodeGen
27 | GenTypesDemo.API.Definition
28 | GenTypesDemo.API.DomainError
29 | GenTypesDemo.API.ManageUsers
30 | GenTypesDemo.API.Types
31 | GenTypesDemo.API.Types.NotEmptyText
32 | GenTypesDemo.Run
33 | other-modules:
34 | Paths_gentypes_server
35 | hs-source-dirs:
36 | src
37 | default-extensions:
38 | NoImplicitPrelude
39 | OverloadedStrings
40 | ghc-options: -Wall -Werror
41 | build-depends:
42 | aeson
43 | , base >=4.7 && <5
44 | , effectful
45 | , effectful-th
46 | , exceptions
47 | , generic-lens
48 | , jose
49 | , mtl
50 | , purescript-bridge
51 | , random
52 | , rio
53 | , servant
54 | , servant-auth-server
55 | , servant-errors
56 | , servant-foreign
57 | , servant-purescript
58 | , servant-server
59 | , uuid
60 | , wai
61 | , wai-cors
62 | , wai-extra
63 | , warp
64 | default-language: Haskell2010
65 |
66 | executable gentypes-codegen
67 | main-is: Main.hs
68 | other-modules:
69 | Paths_gentypes_server
70 | hs-source-dirs:
71 | codegen
72 | default-extensions:
73 | NoImplicitPrelude
74 | OverloadedStrings
75 | ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N
76 | build-depends:
77 | aeson
78 | , base >=4.7 && <5
79 | , effectful
80 | , effectful-th
81 | , exceptions
82 | , generic-lens
83 | , gentypes-server
84 | , jose
85 | , mtl
86 | , purescript-bridge
87 | , random
88 | , rio
89 | , servant
90 | , servant-auth-server
91 | , servant-errors
92 | , servant-foreign
93 | , servant-purescript
94 | , servant-server
95 | , uuid
96 | , wai
97 | , wai-cors
98 | , wai-extra
99 | , warp
100 | default-language: Haskell2010
101 |
102 | executable gentypes-server-exe
103 | main-is: Main.hs
104 | other-modules:
105 | Paths_gentypes_server
106 | hs-source-dirs:
107 | app
108 | default-extensions:
109 | NoImplicitPrelude
110 | OverloadedStrings
111 | ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N
112 | build-depends:
113 | aeson
114 | , base >=4.7 && <5
115 | , effectful
116 | , effectful-th
117 | , exceptions
118 | , generic-lens
119 | , gentypes-server
120 | , jose
121 | , mtl
122 | , purescript-bridge
123 | , random
124 | , rio
125 | , servant
126 | , servant-auth-server
127 | , servant-errors
128 | , servant-foreign
129 | , servant-purescript
130 | , servant-server
131 | , uuid
132 | , wai
133 | , wai-cors
134 | , wai-extra
135 | , warp
136 | default-language: Haskell2010
137 |
138 | test-suite gentypes-server-test
139 | type: exitcode-stdio-1.0
140 | main-is: Spec.hs
141 | other-modules:
142 | Paths_gentypes_server
143 | hs-source-dirs:
144 | test
145 | default-extensions:
146 | NoImplicitPrelude
147 | OverloadedStrings
148 | ghc-options: -Wall -Werror -threaded -rtsopts -with-rtsopts=-N
149 | build-depends:
150 | aeson
151 | , base >=4.7 && <5
152 | , effectful
153 | , effectful-th
154 | , exceptions
155 | , generic-lens
156 | , gentypes-server
157 | , jose
158 | , mtl
159 | , purescript-bridge
160 | , random
161 | , rio
162 | , servant
163 | , servant-auth-server
164 | , servant-errors
165 | , servant-foreign
166 | , servant-purescript
167 | , servant-server
168 | , uuid
169 | , wai
170 | , wai-cors
171 | , wai-extra
172 | , warp
173 | default-language: Haskell2010
174 |
--------------------------------------------------------------------------------
/server/hie.yaml:
--------------------------------------------------------------------------------
1 | cradle:
2 | stack:
3 | - path: "./src"
4 | component: "gentypes-server:lib"
5 |
6 | - path: "./app/Main.hs"
7 | component: "gentypes-server:exe:gentypes-server-exe"
8 |
9 | - path: "./app/Paths_gentypes_server.hs"
10 | component: "gentypes-server:exe:gentypes-server-exe"
11 |
12 | - path: "./test"
13 | component: "gentypes-server:test:gentypes-server-test"
14 |
--------------------------------------------------------------------------------
/server/package.yaml:
--------------------------------------------------------------------------------
1 | name: gentypes-server
2 | version: 0.1.0.0
3 | github: "dnikolovv/gentypes-server"
4 | license: BSD3
5 | author: "Dobromir Nikolov"
6 | maintainer: "example@example.com"
7 | copyright: "2022 Dobromir Nikolov"
8 |
9 | # Metadata used when publishing your package
10 | # synopsis: Short description of your package
11 | # category: Web
12 |
13 | # To avoid duplicated efforts in documentation and dealing with the
14 | # complications of embedding Haddock markup inside cabal files, it is
15 | # common to point users to the README.md file.
16 | description: Please see the README on GitHub at
17 |
18 | dependencies:
19 | - base >= 4.7 && < 5
20 | - rio
21 | - aeson
22 | - mtl
23 | - wai
24 | - wai-extra
25 | - wai-cors
26 | - warp
27 | - random
28 | - uuid
29 | - generic-lens
30 | - servant
31 | - servant-auth-server
32 | - servant-errors
33 | - servant-server
34 | - servant-foreign
35 | - servant-purescript
36 | - purescript-bridge
37 | - jose
38 | - effectful
39 | - effectful-th
40 | - exceptions
41 |
42 | library:
43 | source-dirs: src
44 |
45 | default-extensions:
46 | - NoImplicitPrelude
47 | - OverloadedStrings
48 |
49 | ghc-options:
50 | - -Wall
51 | - -Werror
52 |
53 | executables:
54 | gentypes-codegen:
55 | main: Main.hs
56 | source-dirs: codegen
57 | ghc-options:
58 | - -threaded
59 | - -rtsopts
60 | - -with-rtsopts=-N
61 | dependencies:
62 | - gentypes-server
63 |
64 | gentypes-server-exe:
65 | main: Main.hs
66 | source-dirs: app
67 | ghc-options:
68 | - -threaded
69 | - -rtsopts
70 | - -with-rtsopts=-N
71 | dependencies:
72 | - gentypes-server
73 |
74 | tests:
75 | gentypes-server-test:
76 | main: Spec.hs
77 | source-dirs: test
78 | ghc-options:
79 | - -threaded
80 | - -rtsopts
81 | - -with-rtsopts=-N
82 | dependencies:
83 | - gentypes-server
84 |
--------------------------------------------------------------------------------
/server/run.sh:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env bash
2 | stack run gentypes-server-exe
3 |
--------------------------------------------------------------------------------
/server/src/GenTypesDemo/API/Auth.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE BangPatterns #-}
2 | {-# LANGUAGE DeriveAnyClass #-}
3 | {-# LANGUAGE DeriveGeneric #-}
4 | {-# LANGUAGE DerivingStrategies #-}
5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 |
7 | module GenTypesDemo.API.Auth where
8 |
9 | import Crypto.JWT (emptyClaimsSet, unregisteredClaims)
10 | import Data.Aeson
11 | import qualified Data.Aeson as JSON
12 | import GenTypesDemo.API.Types (Username)
13 | import RIO
14 | import Servant (FromHttpApiData, ToHttpApiData)
15 | import Servant.Auth.Server (FromJWT (decodeJWT), ToJWT (encodeJWT))
16 |
17 | newtype AuthorizationHeader = AuthorizationHeader Text
18 | deriving (Generic)
19 | deriving newtype (ToHttpApiData, FromHttpApiData)
20 | deriving anyclass (FromJSON, ToJSON)
21 |
22 | newtype APIUser = APIUser
23 | { username :: Username
24 | }
25 | deriving (Generic, Show)
26 | deriving anyclass (FromJSON, ToJSON)
27 |
28 | instance ToJWT APIUser where
29 | encodeJWT a = do
30 | let (Object userAsHashmap) = toJSON a
31 | set unregisteredClaims userAsHashmap emptyClaimsSet
32 |
33 | instance FromJWT APIUser where
34 | decodeJWT m =
35 | case fromJSON (m ^. unregisteredClaims . to JSON.Object) of
36 | Success user -> pure user
37 | Error _ -> Left "Unable to deserialize an APIUser from the given JWT."
--------------------------------------------------------------------------------
/server/src/GenTypesDemo/API/CodeGen.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DataKinds #-}
2 | {-# LANGUAGE DeriveGeneric #-}
3 | {-# LANGUAGE FlexibleContexts #-}
4 | {-# LANGUAGE FlexibleInstances #-}
5 | {-# LANGUAGE MultiParamTypeClasses #-}
6 | {-# LANGUAGE RankNTypes #-}
7 | {-# LANGUAGE ScopedTypeVariables #-}
8 | {-# LANGUAGE TypeApplications #-}
9 | {-# LANGUAGE TypeFamilies #-}
10 | {-# LANGUAGE TypeOperators #-}
11 | {-# OPTIONS_GHC -fno-warn-orphans #-}
12 |
13 | module GenTypesDemo.API.CodeGen where
14 |
15 | import GenTypesDemo.API.Auth (AuthorizationHeader)
16 | import GenTypesDemo.API.Definition (UsersAPI)
17 | import GenTypesDemo.API.Types (CreateUserRequest, CreatedAt, Error, UpdateUserRequest, User, UserData, UserId, Username)
18 | import Language.PureScript.Bridge
19 | import Language.PureScript.Bridge.PSTypes
20 | import RIO
21 | import Servant.Auth.Server
22 | import Servant.Foreign
23 | import Servant.PureScript (HasBridge (..), Settings, addTypes, defaultSettings, generateWithSettings)
24 |
25 | codegen :: String -> IO ()
26 | codegen destination =
27 | genPureScriptTypes destination
28 | >> genServant destination
29 |
30 | genServant :: String -> IO ()
31 | genServant dir =
32 | generateWithSettings
33 | mySettings
34 | dir
35 | myBridgeProxy
36 | (Proxy @UsersAPI)
37 |
38 | data MyBridge
39 |
40 | instance
41 | forall lang ftype api etc a.
42 | ( HasForeign lang ftype api,
43 | HasForeignType lang ftype (Maybe AuthorizationHeader)
44 | ) =>
45 | HasForeign lang ftype (Auth (JWT ': etc) a :> api)
46 | where
47 | type Foreign ftype (Auth (JWT ': etc) a :> api) = Foreign ftype api
48 |
49 | foreignFor lang Proxy Proxy subR =
50 | foreignFor lang Proxy (Proxy :: Proxy api) req
51 | where
52 | req = subR {_reqHeaders = HeaderArg arg : _reqHeaders subR}
53 | arg =
54 | Arg
55 | { _argName = PathSegment "Authorization",
56 | _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe AuthorizationHeader))
57 | }
58 |
59 | instance HasBridge MyBridge where
60 | languageBridge _ = buildBridge bridge
61 |
62 | myBridgeProxy :: Proxy MyBridge
63 | myBridgeProxy = Proxy
64 |
65 | mySettings :: Settings
66 | mySettings =
67 | defaultSettings
68 | & addTypes myTypes
69 |
70 | genPureScriptTypes :: String -> IO ()
71 | genPureScriptTypes destination =
72 | writePSTypes
73 | destination
74 | (buildBridge bridge)
75 | myTypes
76 |
77 | bridge :: BridgePart
78 | bridge =
79 | uuidBridge
80 | <|> emailBridge
81 | <|> notEmptyTextBridge
82 | <|> utcTimeBridge
83 | <|> defaultBridge
84 |
85 | -- We'll translate our NotEmptyText to plain text
86 | notEmptyTextBridge :: BridgePart
87 | notEmptyTextBridge = do
88 | typeName ^== "NotEmptyText"
89 | pure psString
90 |
91 | -- But we can also fall back to a strongly typed PureScript version
92 | -- and force client-side validation to be performed
93 | emailBridge :: BridgePart
94 | emailBridge = do
95 | typeName ^== "Email"
96 | -- Our own custom Email type on the front-end
97 | pure $ TypeInfo "" "GenTypesDemo.Utilities.Email" "Email" []
98 |
99 | uuidBridge :: BridgePart
100 | uuidBridge = do
101 | typeName ^== "UUID"
102 | typeModule ^== "Data.UUID" <|> typeModule ^== "Data.UUID.Types.Internal"
103 | pure psUUID
104 |
105 | psUUID :: PSType
106 | psUUID = TypeInfo "web-common" "Data.UUID.Argonaut" "UUID" []
107 |
108 | utcTimeBridge :: BridgePart
109 | utcTimeBridge = do
110 | typeName ^== "UTCTime"
111 | pure psUTCTime
112 |
113 | psUTCTime :: PSType
114 | psUTCTime = TypeInfo "haskell-iso" "Data.Argonaut.JSONDateTime" "JSONDateTime" []
115 |
116 | myTypes :: [SumType 'Haskell]
117 | myTypes =
118 | [ genericShow $ equal $ argonaut $ mkSumType @CreateUserRequest,
119 | order $ genericShow $ equal $ argonaut $ mkSumType @Username,
120 | order $ genericShow $ equal $ argonaut $ mkSumType @UserId,
121 | genericShow $ equal $ argonaut $ mkSumType @UserData,
122 | order $ genericShow $ equal $ argonaut $ mkSumType @CreatedAt,
123 | genericShow $ equal $ argonaut $ mkSumType @User,
124 | genericShow $ equal $ argonaut $ mkSumType @UpdateUserRequest,
125 | order $ genericShow $ equal $ argonaut $ mkSumType @Error,
126 | order $ genericShow $ equal $ argonaut $ mkSumType @AuthorizationHeader
127 | ]
--------------------------------------------------------------------------------
/server/src/GenTypesDemo/API/Definition.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DataKinds #-}
2 | {-# LANGUAGE DerivingStrategies #-}
3 | {-# LANGUAGE FlexibleContexts #-}
4 | {-# LANGUAGE GADTs #-}
5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 | {-# LANGUAGE KindSignatures #-}
7 | {-# LANGUAGE LambdaCase #-}
8 | {-# LANGUAGE RecordWildCards #-}
9 | {-# LANGUAGE TypeApplications #-}
10 | {-# LANGUAGE TypeOperators #-}
11 |
12 | module GenTypesDemo.API.Definition where
13 |
14 | import Effectful (Eff)
15 | import qualified Effectful as E
16 | import qualified Effectful.Error.Static as ES
17 | import GenTypesDemo.API.Auth (APIUser)
18 | import GenTypesDemo.API.DomainError (DomainError)
19 | import qualified GenTypesDemo.API.DomainError as DomainError
20 | import GenTypesDemo.API.ManageUsers (ManageUsers, deleteUser, getAllUsers, getUser, newUser, updateUser)
21 | import GenTypesDemo.API.Types
22 | import RIO
23 | import Servant
24 | import Servant.Auth.Server
25 |
26 | -- Known issues
27 | -- NoContent endpoints will fail deserialization because the PureScript front-end will expect an [] to deserialize into Unit
28 | -- Required QueryParams won't get properly serialized
29 | -- newtypes with named fields don't get serialized properly e.g. Username = Username { unUsername :: Text }
30 |
31 | type UsersAPI =
32 | PublicAPI
33 | :<|> ProtectedAPI
34 |
35 | type PublicAPI =
36 | "users" :> Get '[JSON] [User]
37 | :<|> ( "user"
38 | :> ( Capture "userId" UserId :> Get '[JSON] User
39 | :<|> ReqBody '[JSON] CreateUserRequest :> Post '[JSON] User
40 | :<|> Capture "userId" UserId :> ReqBody '[JSON] UpdateUserRequest :> Put '[JSON] ()
41 | )
42 | )
43 |
44 | type ProtectedAPI =
45 | Auth '[JWT] APIUser
46 | :> ("user" :> Capture "userId" UserId :> Delete '[JSON] ())
47 |
48 | type UsersTable = IORef (HashMap UserId UserData)
49 |
50 | server ::
51 | ManageUsers E.:> es =>
52 | ES.Error DomainError E.:> es =>
53 | ServerT UsersAPI (Eff es)
54 | server =
55 | publicServer
56 | :<|> protectedServer
57 | where
58 | publicServer =
59 | getAllUsers
60 | :<|> getUser
61 | :<|> (\CreateUserRequest {..} -> newUser email username)
62 | :<|> (\uId UpdateUserRequest {..} -> updateUser uId newEmail newUsername)
63 |
64 | protectedServer (Authenticated _) uId = do
65 | deleteUser uId
66 | protectedServer _ _ =
67 | ES.throwError DomainError.Unauthorized
--------------------------------------------------------------------------------
/server/src/GenTypesDemo/API/DomainError.hs:
--------------------------------------------------------------------------------
1 | module GenTypesDemo.API.DomainError where
2 |
3 | import RIO (Text)
4 |
5 | data DomainError
6 | = ValidationError Text
7 | | NotFound Text
8 | | Unauthorized
--------------------------------------------------------------------------------
/server/src/GenTypesDemo/API/ManageUsers.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DataKinds #-}
2 | {-# LANGUAGE FlexibleContexts #-}
3 | {-# LANGUAGE GADTs #-}
4 | {-# LANGUAGE KindSignatures #-}
5 | {-# LANGUAGE ScopedTypeVariables #-}
6 | {-# LANGUAGE TemplateHaskell #-}
7 | {-# LANGUAGE TypeFamilies #-}
8 | {-# LANGUAGE TypeOperators #-}
9 |
10 | module GenTypesDemo.API.ManageUsers where
11 |
12 | import Effectful
13 | import Effectful.TH
14 | import GenTypesDemo.API.Types (Email, User, UserId, Username)
15 | import RIO
16 |
17 | data ManageUsers :: Effect where
18 | GetAllUsers :: ManageUsers m [User]
19 | GetUser :: UserId -> ManageUsers m User
20 | NewUser :: Email -> Username -> ManageUsers m User
21 | DeleteUser :: UserId -> ManageUsers m ()
22 | UpdateUser :: UserId -> Maybe Email -> Maybe Username -> ManageUsers m ()
23 |
24 | type instance DispatchOf ManageUsers = 'Dynamic
25 |
26 | makeEffect ''ManageUsers
--------------------------------------------------------------------------------
/server/src/GenTypesDemo/API/Types.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveAnyClass #-}
2 | {-# LANGUAGE DeriveGeneric #-}
3 | {-# LANGUAGE DerivingStrategies #-}
4 | {-# LANGUAGE DuplicateRecordFields #-}
5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 |
7 | module GenTypesDemo.API.Types where
8 |
9 | import Data.Aeson
10 | import Data.UUID (UUID)
11 | import RIO
12 | import RIO.Time (UTCTime)
13 | import Servant (FromHttpApiData)
14 | import GenTypesDemo.API.Types.NotEmptyText (NotEmptyText)
15 |
16 | data Error = Error
17 | { error :: Text
18 | , status :: Int
19 | }
20 | deriving (Generic)
21 | deriving anyclass (ToJSON, FromJSON)
22 |
23 | data CreateUserRequest = CreateUserRequest
24 | { email :: Email,
25 | username :: Username
26 | }
27 | deriving (Generic)
28 | deriving anyclass (ToJSON, FromJSON)
29 |
30 | data User = User
31 | { id :: UserId,
32 | info :: UserData
33 | }
34 | deriving (Generic)
35 | deriving anyclass (ToJSON, FromJSON)
36 |
37 | data UserData = UserData
38 | { email :: Email,
39 | username :: Username,
40 | created :: CreatedAt
41 | }
42 | deriving (Generic)
43 | deriving anyclass (ToJSON, FromJSON)
44 |
45 | data UpdateUserRequest = UpdateUserRequest
46 | { newEmail :: Maybe Email,
47 | newUsername :: Maybe Username
48 | }
49 | deriving (Generic)
50 | deriving anyclass (ToJSON, FromJSON)
51 |
52 | newtype UserId = UserId UUID
53 | deriving (Generic)
54 | deriving newtype (Eq, Ord, Hashable, ToJSON, FromJSON, FromHttpApiData)
55 |
56 | newtype CreatedAt = CreatedAt UTCTime
57 | deriving (Generic)
58 | deriving newtype (ToJSON, FromJSON, Eq, Ord)
59 |
60 | newtype Email = Email Text
61 | deriving (Generic)
62 | deriving newtype (ToJSON, FromJSON)
63 |
64 | newtype Username = Username NotEmptyText
65 | deriving (Generic)
66 | deriving newtype (Show, ToJSON, FromJSON)
--------------------------------------------------------------------------------
/server/src/GenTypesDemo/API/Types/NotEmptyText.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DerivingStrategies #-}
2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 | {-# LANGUAGE PatternSynonyms #-}
4 | {-# LANGUAGE ViewPatterns #-}
5 |
6 | module GenTypesDemo.API.Types.NotEmptyText
7 | ( NotEmptyText,
8 | unNotEmptyText,
9 | mkNotEmptyText,
10 | mkNotEmptyTextMay,
11 | unsafeMkNotEmptyText,
12 | pattern NotEmptyText,
13 | )
14 | where
15 |
16 | import Data.Aeson
17 | ( FromJSON (parseJSON),
18 | ToJSON,
19 | Value (String),
20 | )
21 | import Data.Aeson.Types (typeMismatch)
22 | import GHC.Base (coerce)
23 | import RIO
24 | import RIO.Text (pack, strip, uncons)
25 | import Text.Read (Read (readsPrec))
26 |
27 | newtype NotEmptyText = MkNotEmptyText Text
28 | deriving newtype (ToJSON, Eq, Show)
29 |
30 | unNotEmptyText :: NotEmptyText -> Text
31 | unNotEmptyText = coerce
32 |
33 | instance FromJSON NotEmptyText where
34 | parseJSON (String str) =
35 | case mkNotEmptyText str of
36 | Right text -> pure text
37 | Left err -> fail (show err)
38 | parseJSON other =
39 | typeMismatch "Object or String" other
40 |
41 | pattern NotEmptyText :: Text -> NotEmptyText
42 | pattern NotEmptyText text <- MkNotEmptyText text
43 |
44 | instance Read NotEmptyText where
45 | readsPrec _ = readTextWrapper MkNotEmptyText
46 |
47 | unsafeMkNotEmptyText :: Text -> NotEmptyText
48 | unsafeMkNotEmptyText = fromMaybe (error "Tried to construct non-empty text value.") . mkNotEmptyTextMay
49 |
50 | mkNotEmptyText :: Text -> Either Text NotEmptyText
51 | mkNotEmptyText (uncons . strip -> Nothing) =
52 | Left "Should not be empty."
53 | mkNotEmptyText text = Right $ MkNotEmptyText text
54 |
55 | mkNotEmptyTextMay :: Text -> Maybe NotEmptyText
56 | mkNotEmptyTextMay = eitherToMaybe . mkNotEmptyText
57 |
58 | readTextWrapper :: IsString b => (Text -> a) -> String -> [(a, b)]
59 | readTextWrapper constructor input = [(constructor (pack input), "")]
60 |
61 | eitherToMaybe :: Either a b -> Maybe b
62 | eitherToMaybe (Right val) = Just val
63 | eitherToMaybe _ = Nothing
--------------------------------------------------------------------------------
/server/src/GenTypesDemo/Run.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DataKinds #-}
2 | {-# LANGUAGE FlexibleContexts #-}
3 | {-# LANGUAGE GADTs #-}
4 | {-# LANGUAGE LambdaCase #-}
5 | {-# LANGUAGE TypeApplications #-}
6 | {-# LANGUAGE TypeOperators #-}
7 |
8 | module GenTypesDemo.Run where
9 |
10 | import Control.Monad.Except (ExceptT (ExceptT))
11 | import qualified Data.Aeson as JSON
12 | import Data.Generics.Product (HasType (typed))
13 | import Data.List (sortOn)
14 | import qualified Data.UUID as UUID
15 | import qualified Data.UUID.V4 as UUID
16 | import Effectful
17 | import Effectful.Dispatch.Dynamic (interpret)
18 | import Effectful.Error.Static (Error, runErrorNoCallStack, throwError)
19 | import GenTypesDemo.API.Definition (UsersAPI, UsersTable, server)
20 | import GenTypesDemo.API.DomainError (DomainError (NotFound, Unauthorized, ValidationError))
21 | import GenTypesDemo.API.ManageUsers (ManageUsers (DeleteUser, GetAllUsers, GetUser, NewUser, UpdateUser), getUser)
22 | import GenTypesDemo.API.Types (CreatedAt (CreatedAt), Email (Email), User (User), UserData (UserData), UserId (UserId), Username (Username), created, info)
23 | import qualified GenTypesDemo.API.Types as API
24 | import GenTypesDemo.API.Types.NotEmptyText (unsafeMkNotEmptyText)
25 | import Network.Wai (Middleware)
26 | import Network.Wai.Handler.Warp (defaultSettings, runSettings, setBeforeMainLoop, setPort)
27 | import Network.Wai.Middleware.Cors
28 | import Network.Wai.Middleware.RequestLogger (logStdoutDev)
29 | import Network.Wai.Middleware.Servant.Errors (errorMwDefJson)
30 | import RIO
31 | import qualified RIO.HashMap as HM
32 | import RIO.Time (getCurrentTime)
33 | import qualified Servant
34 | import Servant.Auth.Server (CookieSettings, JWTSettings, defaultCookieSettings, defaultJWTSettings, fromSecret)
35 | import Servant.Server (Context (EmptyContext, (:.)), HasServer (hoistServerWithContext), ServerError (errBody, errHTTPCode, errHeaders), err400, err401, err404, serveWithContext)
36 | import System.IO (print)
37 |
38 | run :: IO ()
39 | run = do
40 | initializeUsers
41 | >>= runSettings
42 | ( setPort port $
43 | setBeforeMainLoop
44 | (print $ "Running on port " <> show port)
45 | defaultSettings
46 | )
47 | . corsMiddleware allowedCors
48 | . errorMwDefJson
49 | . logStdoutDev
50 | . waiApp
51 | where
52 | waiApp users = do
53 | let jwtCfg = defaultJWTSettings (fromSecret . fromString $ "this secret is kept very very securely")
54 | cookieCfg = defaultCookieSettings
55 | context = cookieCfg :. jwtCfg :. EmptyContext
56 |
57 | serveWithContext usersApi context (hoistServerWithContext usersApi (Proxy :: Proxy '[CookieSettings, JWTSettings]) (effToHandler users) server)
58 | port = 3005
59 | allowedCors = (["http://localhost:1234"], True)
60 | usersApi = Proxy @UsersAPI
61 | initializeUsers = do
62 | now <- CreatedAt <$> getCurrentTime
63 | newIORef $
64 | HM.fromList
65 | [ ( UserId $ unsafeUUIDFromText "0290ee1e-1a64-4ef6-89c1-f8cd3d6298a1",
66 | UserData
67 | (Email "1@email.com")
68 | (Username . unsafeMkNotEmptyText $ "one")
69 | now
70 | ),
71 | ( UserId $ unsafeUUIDFromText "993ba001-6d6d-49b2-bcfa-e00586382ce6",
72 | UserData
73 | (Email "2@email.com")
74 | (Username . unsafeMkNotEmptyText $ "two")
75 | now
76 | ),
77 | ( UserId $ unsafeUUIDFromText "6ab9869c-db81-46b6-ac7b-306d1f0be023",
78 | UserData
79 | (Email "3@email.com")
80 | (Username . unsafeMkNotEmptyText $ "three")
81 | now
82 | ),
83 | ( UserId $ unsafeUUIDFromText "dda3db68-744e-4250-803f-25168f9f8d87",
84 | UserData
85 | (Email "11@email.com")
86 | (Username . unsafeMkNotEmptyText $ "eleven")
87 | now
88 | )
89 | ]
90 |
91 | unsafeUUIDFromText = fromMaybe (error "nope") . UUID.fromText
92 |
93 | effToHandler :: UsersTable -> Eff [ManageUsers, Error DomainError, IOE] a -> Servant.Handler a
94 | effToHandler usersRef m = do
95 | result <- liftIO . runEff . runErrorNoCallStack @DomainError . runInMemoryUserStorage usersRef $ m
96 |
97 | Servant.Handler $ ExceptT (pure . mapLeft toServerError $ result)
98 | where
99 | toServerError = \case
100 | ValidationError t -> servantErrorWithText err400 t
101 | NotFound t -> servantErrorWithText err404 t
102 | Unauthorized -> servantErrorWithText err401 "Unauthorized."
103 |
104 | runInMemoryUserStorage ::
105 | ( IOE :> es,
106 | Error DomainError :> es
107 | ) =>
108 | UsersTable ->
109 | Eff (ManageUsers : es) a ->
110 | Eff es a
111 | runInMemoryUserStorage usersRef = interpret $ \_ -> \case
112 | GetAllUsers -> do
113 | sortOn (created . info) . map (uncurry User) . HM.toList <$> readIORef usersRef
114 | GetUser uId -> do
115 | userMay <- lookupUser uId
116 | case userMay of
117 | Just u -> pure $ User uId u
118 | Nothing ->
119 | throwError $ NotFound "User not found."
120 | NewUser email username -> do
121 | newUserId <- UserId <$> liftIO UUID.nextRandom
122 | now <- CreatedAt <$> getCurrentTime
123 | let userData = UserData email username now
124 | modifyIORef' usersRef $ HM.insert newUserId userData
125 | runInMemoryUserStorage usersRef (getUser newUserId)
126 | DeleteUser uId -> do
127 | modifyIORef' usersRef (HM.delete uId) >> pure ()
128 | UpdateUser uId newEmail newUsername -> do
129 | validate (isJust <$> lookupUser uId) $
130 | ValidationError "Unexisting user."
131 |
132 | modifyIORef' usersRef $
133 | HM.adjust
134 | ( \userData ->
135 | userData
136 | & typed @Email %~ (`fromMaybe` newEmail)
137 | & typed @Username %~ (`fromMaybe` newUsername)
138 | )
139 | uId
140 | where
141 | validate condition err =
142 | condition >>= \result ->
143 | if result
144 | then pure ()
145 | else throwError err
146 |
147 | lookupUser :: MonadIO m => UserId -> m (Maybe UserData)
148 | lookupUser uId = HM.lookup uId <$> readIORef usersRef
149 |
150 | servantErrorWithText ::
151 | ServerError ->
152 | Text ->
153 | ServerError
154 | servantErrorWithText sErr msg =
155 | sErr
156 | { errBody = errorBody (errHTTPCode sErr),
157 | errHeaders = [jsonHeaders]
158 | }
159 | where
160 | errorBody code = JSON.encode $ API.Error msg code
161 |
162 | jsonHeaders =
163 | (fromString "Content-Type", "application/json;charset=utf-8")
164 |
165 | type SendCredentials = Bool
166 |
167 | type Origins = ([Origin], SendCredentials)
168 |
169 | corsMiddleware :: Origins -> Middleware
170 | corsMiddleware origins = do
171 | cors $
172 | const $
173 | Just $
174 | simpleCorsResourcePolicy
175 | { corsMethods = ["PUT", "GET", "DELETE", "HEAD", "OPTIONS", "POST"],
176 | corsRequestHeaders = ["content-type", "authorization", "sentry-trace"],
177 | corsOrigins = Just origins
178 | }
--------------------------------------------------------------------------------
/server/stack.yaml:
--------------------------------------------------------------------------------
1 | # This file was automatically generated by 'stack init'
2 | #
3 | # Some commonly used options have been documented as comments in this file.
4 | # For advanced use and comprehensive documentation of the format, please see:
5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/
6 |
7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version.
8 | # A snapshot resolver dictates the compiler version and the set of packages
9 | # to be used for project dependencies. For example:
10 | #
11 | # resolver: lts-3.5
12 | # resolver: nightly-2015-09-21
13 | # resolver: ghc-7.10.2
14 | #
15 | # The location of a snapshot can be provided as a file or url. Stack assumes
16 | # a snapshot provided as a file might change, whereas a url resource does not.
17 | #
18 | # resolver: ./custom-snapshot.yaml
19 | # resolver: https://example.com/snapshots/2018-01-01.yaml
20 | resolver: lts-18.28
21 |
22 | # User packages to be built.
23 | # Various formats can be used as shown in the example below.
24 | #
25 | # packages:
26 | # - some-directory
27 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
28 | # subdirs:
29 | # - auto-update
30 | # - wai
31 | packages:
32 | - .
33 | # Dependency packages to be pulled from upstream that are not in the resolver.
34 | # These entries can reference officially published versions as well as
35 | # forks / in-progress versions pinned to a git hash. For example:
36 | #
37 | extra-deps:
38 | - git: https://github.com/input-output-hk/purescript-bridge.git
39 | commit: 47a1f11825a0f9445e0f98792f79172efef66c00
40 | - git: https://github.com/input-output-hk/servant-purescript.git
41 | commit: 002e172173ad2f2f69f98a3b56b7312364f23afe
42 | - effectful-1.0.0.0
43 | - effectful-core-1.0.0.0@sha256:04db3df6e435b1df037b63064e3b1bd3f7f915785b4d1b2a9f632f9368821fa2,3675
44 | - effectful-th-1.0.0.0@sha256:46842eeea2ca1ca2ab8a86302de84ec1367f4cb047e49256f386aec123b7f82b,2428
45 | # - acme-missiles-0.3
46 | # - git: https://github.com/commercialhaskell/stack.git
47 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
48 | #
49 | # extra-deps: []
50 |
51 | # Override default flag values for local packages and extra-deps
52 | # flags: {}
53 |
54 | # Extra package databases containing global packages
55 | # extra-package-dbs: []
56 |
57 | # Control whether we use the GHC we find on the path
58 | # system-ghc: true
59 | #
60 | # Require a specific version of stack, using version ranges
61 | # require-stack-version: -any # Default
62 | # require-stack-version: ">=2.7"
63 | #
64 | # Override the architecture used by stack, especially useful on Windows
65 | # arch: i386
66 | # arch: x86_64
67 | #
68 | # Extra directories used by stack for building
69 | # extra-include-dirs: [/path/to/dir]
70 | # extra-lib-dirs: [/path/to/dir]
71 | #
72 | # Allow a newer minor version of GHC than the snapshot specifies
73 | # compiler-check: newer-minor
74 |
--------------------------------------------------------------------------------
/server/stack.yaml.lock:
--------------------------------------------------------------------------------
1 | # This file was autogenerated by Stack.
2 | # You should not edit this file by hand.
3 | # For more information, please see the documentation at:
4 | # https://docs.haskellstack.org/en/stable/lock_files
5 |
6 | packages:
7 | - completed:
8 | name: purescript-bridge
9 | version: 0.14.0.0
10 | git: https://github.com/input-output-hk/purescript-bridge.git
11 | pantry-tree:
12 | size: 2202
13 | sha256: f064953b17907940cc3df62ea778626372747b5879fcf0488c9ae377cfc98fee
14 | commit: 47a1f11825a0f9445e0f98792f79172efef66c00
15 | original:
16 | git: https://github.com/input-output-hk/purescript-bridge.git
17 | commit: 47a1f11825a0f9445e0f98792f79172efef66c00
18 | - completed:
19 | name: servant-purescript
20 | version: 0.9.0.2
21 | git: https://github.com/input-output-hk/servant-purescript.git
22 | pantry-tree:
23 | size: 1204
24 | sha256: ee672215ec28d18b333f885cd1767943c4260a81fc0cfaf9844a6e6caf34c584
25 | commit: 002e172173ad2f2f69f98a3b56b7312364f23afe
26 | original:
27 | git: https://github.com/input-output-hk/servant-purescript.git
28 | commit: 002e172173ad2f2f69f98a3b56b7312364f23afe
29 | - completed:
30 | hackage: effectful-1.0.0.0@sha256:2bd7706a82eb694d4801e194e22078b9d17de0df37d895014a94f58ca72fc493,6272
31 | pantry-tree:
32 | size: 2490
33 | sha256: c7f828a1c06bc535c0ee30837d122f3d243bd6e7e652d17ba739d9c61b032b83
34 | original:
35 | hackage: effectful-1.0.0.0
36 | - completed:
37 | hackage: effectful-core-1.0.0.0@sha256:04db3df6e435b1df037b63064e3b1bd3f7f915785b4d1b2a9f632f9368821fa2,3675
38 | pantry-tree:
39 | size: 1854
40 | sha256: 671032384f225a7c74d450393769ea68c710f6089069324beeb74b8d23a33449
41 | original:
42 | hackage: effectful-core-1.0.0.0@sha256:04db3df6e435b1df037b63064e3b1bd3f7f915785b4d1b2a9f632f9368821fa2,3675
43 | - completed:
44 | hackage: effectful-th-1.0.0.0@sha256:46842eeea2ca1ca2ab8a86302de84ec1367f4cb047e49256f386aec123b7f82b,2428
45 | pantry-tree:
46 | size: 327
47 | sha256: 9b65d503d6e086219a551800356b773c3ee8a541b83d1a7264648365eeb48545
48 | original:
49 | hackage: effectful-th-1.0.0.0@sha256:46842eeea2ca1ca2ab8a86302de84ec1367f4cb047e49256f386aec123b7f82b,2428
50 | snapshots:
51 | - completed:
52 | size: 590100
53 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml
54 | sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68
55 | original: lts-18.28
56 |
--------------------------------------------------------------------------------
/server/test/Spec.hs:
--------------------------------------------------------------------------------
1 | main :: IO ()
2 | main = putStrLn "Test suite not yet implemented"
3 |
--------------------------------------------------------------------------------