├── 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 | ![Demo](demo.gif) 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 | --------------------------------------------------------------------------------