├── .envrc ├── .github ├── CODE_OF_CONDUCT.md └── workflows │ └── ci.yaml ├── .gitignore ├── LICENSE ├── README.md ├── db.sql ├── flake.lock ├── flake.nix ├── justfile ├── nix ├── devshell.nix ├── integration-test.nix ├── nixpkgs.nix ├── scripts.nix ├── services │ ├── default.nix │ └── postgrest.nix ├── todo-app-services.nix └── todo-app.nix ├── src ├── Main.hs └── TodoApp │ └── Request.hs └── todo-app.cabal /.envrc: -------------------------------------------------------------------------------- 1 | use flake 2 | -------------------------------------------------------------------------------- /.github/CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | This document, adapted from [The Ruby Community Conduct Guideline](https://www.ruby-lang.org/en/conduct/), provides community guidelines for a safe, respectful, productive, and collaborative place for any person who is willing to contribute to the associated project. It applies to all “collaborative space”, which is defined as community communications channels (such as mailing lists, submitted patches, commit comments, etc.). 2 | 3 | - Participants will be tolerant of opposing views. 4 | - Participants must ensure that their language and actions are free of personal attacks and disparaging personal remarks. 5 | - When interpreting the words and actions of others, participants should always assume good intentions. 6 | - Behaviour which can be reasonably considered harassment will not be tolerated. 7 | 8 | -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: "CI" 2 | on: 3 | # Run only when pushing to master branch, and making PRs 4 | push: 5 | branches: 6 | - master 7 | pull_request: 8 | jobs: 9 | build: 10 | runs-on: ${{ matrix.os }} 11 | strategy: 12 | matrix: 13 | os: [ubuntu-latest, macos-latest] 14 | steps: 15 | - uses: actions/checkout@v2 16 | # https://omnix.page/om/ci.html#gh-simple 17 | - uses: actions/checkout@v4 18 | - uses: DeterminateSystems/nix-installer-action@main 19 | - uses: DeterminateSystems/magic-nix-cache-action@main 20 | - name: Install omnix 21 | run: nix --accept-flake-config profile install "github:juspay/omnix" 22 | - run: om ci 23 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # cabal 2 | dist 3 | dist-* 4 | cabal.project.local 5 | cabal.project.local~ 6 | 7 | # postgrest 8 | data 9 | 10 | # nix 11 | result 12 | /.direnv 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2023 Juspay 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # todo-app 2 | 3 | A simple TODO app in Haskell using [PostgREST](https://postgrest.org/) as a RESTful API for [PostgreSQL](https://www.postgresql.org/). 4 | 5 | > [!NOTE] 6 | > This app is a demo to showcase how developer experience in a Haskell project can be improved using Nix. We primarily use [haskell-flake], [services-flake] and [flake-parts] to achieve this. 7 | 8 | [haskell-flake]: https://community.flake.parts/haskell-flake 9 | [services-flake]: https://community.flake.parts/services-flake 10 | [flake-parts]: https://flake.parts 11 | 12 | ## Tutorial 13 | 14 | Learn with [our blog post series](https://nixos.asia/en/nixify-haskell): 15 | 16 | - [Introduction](https://nixos.asia/en/nixify-haskell-nixpkgs) 17 | - [Switch to flake-parts](https://nixos.asia/en/nixify-haskell-parts) 18 | - [Simplify Nix using haskell-flake](https://nixos.asia/en/nixify-haskell-flake) 19 | - [Integrate external services using services-flake](https://nixos.asia/en/nixify-services-flake) 20 | - ... 21 | 22 | ## Getting Started 23 | 24 | [Install Nix](https://nixos.asia/en/install) 25 | 26 | ## Development 27 | 28 | ```sh 29 | nix develop 30 | ``` 31 | To enter development shell on `cd`, use [direnv](https://nixos.asia/en/direnv) 32 | 33 | > [!NOTE] 34 | > `just services` starts postgres and postgrest, both of which bind to Unix socket. 35 | 36 | ```sh 37 | just services 38 | # Watch for changes in the Haskell code 39 | just watch 40 | ``` 41 | 42 | ## Run through Nix 43 | 44 | > [!NOTE] 45 | > `todo-app-services-tcp` starts postgres, which listens on Unix socket, while postgrest listens on TCP port 3000. 46 | 47 | ```sh 48 | nix run github:juspay/todo-app#todo-app-services-tcp 49 | nix run github:juspay/todo-app -- view 50 | ``` 51 | -------------------------------------------------------------------------------- /db.sql: -------------------------------------------------------------------------------- 1 | -- This schema has been taken from https://postgrest.org/en/stable/tutorials/tut0.html 2 | create schema api; 3 | create table if not exists api.todos ( 4 | id serial primary key, done boolean not null default false, 5 | task text not null 6 | ); 7 | insert into api.todos (task) 8 | values 9 | ('finish tutorial 0'), 10 | ('pat self on back'); 11 | create role authenticator noinherit login password 'mysecretpassword'; 12 | create role todo_user nologin; 13 | grant todo_user to authenticator; 14 | -- Granting all permissions for tutorial purposes only 15 | -- Follow this to use JWT and secure your api calls: https://postgrest.org/en/stable/tutorials/tut1.html 16 | grant all on schema api to todo_user; 17 | grant all on api.todos to todo_user; 18 | grant all on sequence api.todos_id_seq to todo_user; 19 | -- To reset the sequence 20 | create function api.reset_id() returns void language plpgsql as $$ begin alter sequence api.todos_id_seq restart with 1; 21 | end; 22 | $$; 23 | -- This is needed because to change ownership of sequence, the same owner has to own the table 24 | -- TODO: Find a better way to do this 25 | alter table 26 | api.todos owner to todo_user; 27 | alter sequence api.todos_id_seq owner to todo_user; 28 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-parts": { 4 | "inputs": { 5 | "nixpkgs-lib": "nixpkgs-lib" 6 | }, 7 | "locked": { 8 | "lastModified": 1727826117, 9 | "narHash": "sha256-K5ZLCyfO/Zj9mPFldf3iwS6oZStJcU4tSpiXTMYaaL0=", 10 | "owner": "hercules-ci", 11 | "repo": "flake-parts", 12 | "rev": "3d04084d54bedc3d6b8b736c70ef449225c361b1", 13 | "type": "github" 14 | }, 15 | "original": { 16 | "owner": "hercules-ci", 17 | "repo": "flake-parts", 18 | "type": "github" 19 | } 20 | }, 21 | "haskell-flake": { 22 | "locked": { 23 | "lastModified": 1728227251, 24 | "narHash": "sha256-JLDhMFyGyFe0QJAbCuSxB7/kjUCA7uUAMa6BFRORwXk=", 25 | "owner": "srid", 26 | "repo": "haskell-flake", 27 | "rev": "9cbfbfc38f1fbf9a0f471795c84780211875fd45", 28 | "type": "github" 29 | }, 30 | "original": { 31 | "owner": "srid", 32 | "repo": "haskell-flake", 33 | "type": "github" 34 | } 35 | }, 36 | "nixpkgs": { 37 | "locked": { 38 | "lastModified": 1679793451, 39 | "narHash": "sha256-JafTtgMDATE8dZOImBhWMA9RCn9AP8FVOpN+9K/tTlg=", 40 | "owner": "NixOS", 41 | "repo": "nixpkgs", 42 | "rev": "0cd51a933d91078775b300cf0f29aa3495231aa2", 43 | "type": "github" 44 | }, 45 | "original": { 46 | "owner": "NixOS", 47 | "ref": "nixpkgs-unstable", 48 | "repo": "nixpkgs", 49 | "type": "github" 50 | } 51 | }, 52 | "nixpkgs-latest": { 53 | "locked": { 54 | "lastModified": 1728538411, 55 | "narHash": "sha256-f0SBJz1eZ2yOuKUr5CA9BHULGXVSn6miBuUWdTyhUhU=", 56 | "owner": "NixOS", 57 | "repo": "nixpkgs", 58 | "rev": "b69de56fac8c2b6f8fd27f2eca01dcda8e0a4221", 59 | "type": "github" 60 | }, 61 | "original": { 62 | "owner": "NixOS", 63 | "ref": "nixpkgs-unstable", 64 | "repo": "nixpkgs", 65 | "type": "github" 66 | } 67 | }, 68 | "nixpkgs-lib": { 69 | "locked": { 70 | "lastModified": 1727825735, 71 | "narHash": "sha256-0xHYkMkeLVQAMa7gvkddbPqpxph+hDzdu1XdGPJR+Os=", 72 | "type": "tarball", 73 | "url": "https://github.com/NixOS/nixpkgs/archive/fb192fec7cc7a4c26d51779e9bab07ce6fa5597a.tar.gz" 74 | }, 75 | "original": { 76 | "type": "tarball", 77 | "url": "https://github.com/NixOS/nixpkgs/archive/fb192fec7cc7a4c26d51779e9bab07ce6fa5597a.tar.gz" 78 | } 79 | }, 80 | "process-compose-flake": { 81 | "locked": { 82 | "lastModified": 1727723765, 83 | "narHash": "sha256-/3az0h2Zp02bjJQKliR0PEQiT+FMLOR1GumhH42jA4w=", 84 | "owner": "Platonic-Systems", 85 | "repo": "process-compose-flake", 86 | "rev": "22f2aeb7e0b88006d1d27065f8422f2790d99e47", 87 | "type": "github" 88 | }, 89 | "original": { 90 | "owner": "Platonic-Systems", 91 | "repo": "process-compose-flake", 92 | "type": "github" 93 | } 94 | }, 95 | "root": { 96 | "inputs": { 97 | "flake-parts": "flake-parts", 98 | "haskell-flake": "haskell-flake", 99 | "nixpkgs": "nixpkgs", 100 | "nixpkgs-latest": "nixpkgs-latest", 101 | "process-compose-flake": "process-compose-flake", 102 | "services-flake": "services-flake" 103 | } 104 | }, 105 | "services-flake": { 106 | "locked": { 107 | "lastModified": 1728811751, 108 | "narHash": "sha256-IrwycNtt6jxJGCi+QJ8Bbzt9flg0vNeGLAR0KBbj4a8=", 109 | "owner": "juspay", 110 | "repo": "services-flake", 111 | "rev": "e9f663036f3b1b1a12b0f136628ef93a8be92443", 112 | "type": "github" 113 | }, 114 | "original": { 115 | "owner": "juspay", 116 | "repo": "services-flake", 117 | "type": "github" 118 | } 119 | } 120 | }, 121 | "root": "root", 122 | "version": 7 123 | } 124 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | inputs = { 3 | nixpkgs.url = "github:NixOS/nixpkgs/nixpkgs-unstable"; 4 | flake-parts.url = "github:hercules-ci/flake-parts"; 5 | haskell-flake.url = "github:srid/haskell-flake"; 6 | 7 | # `process-compose` from `nixpkgs` is not compatible with latest `process-compose-flake` 8 | # FIXME: Use `nixpkgs` after https://github.com/juspay/todo-app/issues/12 9 | nixpkgs-latest.url = "github:NixOS/nixpkgs/nixpkgs-unstable"; 10 | 11 | process-compose-flake.url = "github:Platonic-Systems/process-compose-flake"; 12 | services-flake.url = "github:juspay/services-flake"; 13 | }; 14 | 15 | outputs = inputs: 16 | # mkFlake takes two inputs, `args` and `mod`. Internally it calls `lib.evalModules`(https://nixos.org/manual/nixpkgs/unstable/#module-system-lib-evalModules) 17 | inputs.flake-parts.lib.mkFlake { inherit inputs; } { 18 | systems = [ "x86_64-linux" "x86_64-darwin" "aarch64-linux" "aarch64-darwin" ]; 19 | imports = [ 20 | # This is where we import the haskell-flake module. See ./nix/todo-app.nix for how we use it. 21 | inputs.haskell-flake.flakeModule 22 | # See ./nix/{todo-app-services,integration-test}.nix for how we use it. 23 | inputs.process-compose-flake.flakeModule 24 | ./nix/todo-app-services.nix 25 | ./nix/integration-test.nix 26 | # This is where we override `nixpkgs` to use `process-compose` and `ghciwatch` from `nixpkgs-latest`. 27 | ./nix/nixpkgs.nix 28 | ]; 29 | perSystem = { self', pkgs, ... }: { 30 | imports = [ 31 | ./nix/todo-app.nix 32 | ./nix/devshell.nix 33 | ]; 34 | }; 35 | }; 36 | } 37 | -------------------------------------------------------------------------------- /justfile: -------------------------------------------------------------------------------- 1 | # List all the just commands 2 | default: 3 | @just --list 4 | 5 | # Run external services (postgres and postgrest) 6 | services: 7 | nix run .#todo-app-services 8 | 9 | alias s := services 10 | 11 | # Watch and recompile on changes 12 | watch: 13 | # Executes the main subcommand with the `view` argument after recompiling 14 | ghciwatch --test-ghci ":main view" 15 | 16 | alias w := watch 17 | -------------------------------------------------------------------------------- /nix/devshell.nix: -------------------------------------------------------------------------------- 1 | { pkgs, config, ... }: 2 | { 3 | devShells.default = pkgs.mkShell { 4 | inputsFrom = [ 5 | config.haskellProjects.default.outputs.devShell 6 | ]; 7 | PGRST_SERVER_UNIX_SOCKET = with config.process-compose.todo-app-services.services; 8 | postgrest.unixSocket; 9 | packages = with pkgs; [ 10 | just 11 | ghciwatch 12 | ]; 13 | shellHook = '' 14 | echo 15 | echo "🍎🍎 Run 'just ' to get started" 16 | just 17 | ''; 18 | }; 19 | } 20 | -------------------------------------------------------------------------------- /nix/integration-test.nix: -------------------------------------------------------------------------------- 1 | # Check `todo-app` integration with external services. 2 | { inputs, ... }: 3 | { 4 | perSystem = { self', pkgs, ... }: { 5 | process-compose.todo-app-integ-test = { config, ... }: { 6 | imports = [ 7 | inputs.services-flake.processComposeModules.default 8 | ./services 9 | ]; 10 | services.postgrest.unixSocket = "./data/pgrst.sock"; 11 | # `test` is a reserved name in `process-compose-flake`. 12 | # This process is disabled by default and is only enabled when `nix flake check` is run, 13 | # which is only done in CI. 14 | settings.processes.test = { 15 | environment = { 16 | # If not set, `todo-app` will try to connect to `postgrest` using TCP. 17 | PGRST_SERVER_UNIX_SOCKET = config.services.postgrest.unixSocket; 18 | }; 19 | command = pkgs.writeShellApplication { 20 | name = "todo-app-integration-test"; 21 | runtimeInputs = [ self'.packages.default ]; 22 | # TODO: Capture output and check for expected strings. 23 | text = '' 24 | # Function to print a separator 25 | print_separator() { 26 | echo "----------------------------------------" 27 | echo " $1" 28 | echo "----------------------------------------" 29 | } 30 | print_separator "Test viewing all todos" 31 | todo-app viewAll 32 | 33 | print_separator "Test viewing pending todos" 34 | todo-app view 35 | 36 | print_separator "Test adding a todo" 37 | todo-app add "Buy milk" 38 | 39 | print_separator "Test completing a todo" 40 | # Workaround for https://www.shellcheck.net/wiki/SC1010 41 | todo-app "done" 1 42 | 43 | print_separator "Test deleting a todo" 44 | todo-app delete 1 45 | 46 | print_separator "Test resetting the todo list" 47 | todo-app reset 48 | ''; 49 | }; 50 | depends_on."postgrest".condition = "process_healthy"; 51 | }; 52 | }; 53 | }; 54 | } -------------------------------------------------------------------------------- /nix/nixpkgs.nix: -------------------------------------------------------------------------------- 1 | { inputs, ... }: 2 | { 3 | perSystem = { inputs', system, ... }: { 4 | _module.args.pkgs = import inputs.nixpkgs { 5 | inherit system; 6 | overlays = [ 7 | (_: _: { 8 | inherit (inputs'.nixpkgs-latest.legacyPackages) process-compose ghciwatch; 9 | }) 10 | ]; 11 | }; 12 | }; 13 | } -------------------------------------------------------------------------------- /nix/scripts.nix: -------------------------------------------------------------------------------- 1 | { pkgs, lib, config, ... }: 2 | { 3 | options = { 4 | scripts = lib.mkOption { 5 | description = '' 6 | A set of scripts to define as flake apps. 7 | ''; 8 | type = lib.types.attrsOf (lib.types.submodule { 9 | options = { 10 | packages = lib.mkOption { 11 | type = lib.types.listOf lib.types.package; 12 | default = [ ]; 13 | description = '' 14 | Dependencies of the script. 15 | ''; 16 | }; 17 | text = lib.mkOption { 18 | type = lib.types.str; 19 | description = '' 20 | The bash script to execute. 21 | ''; 22 | }; 23 | }; 24 | }); 25 | }; 26 | }; 27 | config = { 28 | apps = 29 | lib.mapAttrs 30 | (name: cfg: { 31 | type = "app"; 32 | program = 33 | let 34 | script = pkgs.writeShellApplication { 35 | name = name; 36 | text = cfg.text; 37 | runtimeInputs = cfg.packages; 38 | }; 39 | in 40 | "${script}/bin/${name}"; 41 | }) 42 | config.scripts; 43 | }; 44 | } 45 | -------------------------------------------------------------------------------- /nix/services/default.nix: -------------------------------------------------------------------------------- 1 | { config, ... }: 2 | { 3 | imports = [ 4 | ./postgrest.nix 5 | ]; 6 | services = { 7 | postgrest.enable = true; 8 | # Start postgres using Unix socket and disable listening on TCP port. 9 | postgres."pg" = { 10 | enable = true; 11 | # Listening on TCP port is disabled by setting `listen_addresses` to empty string. 12 | listen_addresses = ""; 13 | socketDir = config.services.postgres."pg".dataDir; 14 | initialDatabases = [ 15 | { 16 | name = "todo"; 17 | schemas = [ ../../db.sql ]; 18 | } 19 | ]; 20 | }; 21 | }; 22 | 23 | settings.processes.postgrest.depends_on."pg".condition = "process_healthy"; 24 | } -------------------------------------------------------------------------------- /nix/services/postgrest.nix: -------------------------------------------------------------------------------- 1 | # Custom service (not provided by `services-flake`) configuration for `postgrest`. 2 | # See https://community.flake.parts/services-flake/custom-service 3 | { pkgs, lib, config, ... }: 4 | let 5 | inherit (lib) types; 6 | in 7 | { 8 | options = { 9 | services.postgrest = { 10 | enable = lib.mkEnableOption "postgrest"; 11 | unixSocket = lib.mkOption { 12 | type = types.nullOr types.str; 13 | default = null; 14 | description = "The path to the socket to bind to"; 15 | example = "/tmp/pgrst.sock"; 16 | }; 17 | config = lib.mkOption { 18 | type = types.attrsOf types.str; 19 | # TODO: use https://github.com/srid/flake-root for `db-uri` and `server-unix-socket` 20 | default = { 21 | # Note: socket path in connection uri cannot contain `/`, so we need to URL-encode it. 22 | # see https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING-KEYWORD-VALUE 23 | # TODO: re-use `config.services.postgres."pg".dataDir` 24 | db-uri = "postgres://\${PWD//\//%2F}%2Fdata%2Fpg/todo"; 25 | db-schemas = "api"; 26 | db-anon-role = "todo_user"; 27 | }; 28 | }; 29 | }; 30 | }; 31 | config = lib.mkIf config.services.postgrest.enable { 32 | settings.processes.postgrest = { 33 | environment = { 34 | PGRST_DB_SCHEMAS = config.services.postgrest.config.db-schemas; 35 | PGRST_DB_ANON_ROLE = config.services.postgrest.config.db-anon-role; 36 | } // lib.optionalAttrs (config.services.postgrest.unixSocket != null) { 37 | PGRST_SERVER_UNIX_SOCKET = config.services.postgrest.unixSocket; 38 | }; 39 | command = pkgs.writeShellApplication { 40 | name = "pg_rest"; 41 | runtimeInputs = [ pkgs.haskellPackages.postgrest ]; 42 | text = 43 | '' 44 | # Can't be set in `settings.processes.postgrest.environment` because the value has to be evaluated in the shell 45 | PGRST_DB_URI="${config.services.postgrest.config.db-uri}"; 46 | # Have to export explicitly: https://www.shellcheck.net/wiki/SC2155 47 | export PGRST_DB_URI; 48 | exec postgrest 49 | ''; 50 | }; 51 | readiness_probe = { 52 | # `http://localhost` is to tell curl to use the HTTP protocol and `localhost` is just a dummy hostname 53 | exec.command = if config.services.postgrest.unixSocket != null then 54 | "${lib.getExe' pkgs.curl "curl"} --unix-socket ${config.services.postgrest.unixSocket} http://localhost" 55 | else 56 | # TODO: configurable hostname and port 57 | "${lib.getExe pkgs.curl} http://localhost:3000"; 58 | }; 59 | }; 60 | }; 61 | } 62 | -------------------------------------------------------------------------------- /nix/todo-app-services.nix: -------------------------------------------------------------------------------- 1 | # `process-compose` configuration for `todo-app` external services (namely `postgresql` and `postgrest`). 2 | { inputs, ... }: 3 | { 4 | perSystem = { 5 | # Both postgres and postgrest bind to unix socket -- useful for local development and in CI. 6 | process-compose.todo-app-services = { 7 | imports = [ 8 | inputs.services-flake.processComposeModules.default 9 | ./services 10 | ]; 11 | services.postgrest.unixSocket = "./data/pgrst.sock"; 12 | }; 13 | 14 | # Only postgres binds to unix socket, while postgrest binds to TCP port. 15 | process-compose.todo-app-services-tcp = { 16 | imports = [ 17 | inputs.services-flake.processComposeModules.default 18 | ./services 19 | ]; 20 | }; 21 | }; 22 | } -------------------------------------------------------------------------------- /nix/todo-app.nix: -------------------------------------------------------------------------------- 1 | { self', pkgs, ... }: 2 | { 3 | # `haskellProjects` is the top-level submodule provided by haskell-flake, which we import in `flake.nix` 4 | haskellProjects.default = { 5 | # The default haskell-flake configuration is sufficient for our purposes. It provides both packages and devShell automatically based on the Haskell package, as defined in our .cabal file. 6 | # 7 | # For customization, see 8 | # https://github.com/srid/haskell-flake 9 | autoWire = [ "packages" ]; 10 | }; 11 | packages = { 12 | default = self'.packages.todo-app; 13 | }; 14 | } 15 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Data.Aeson (Result (..)) 4 | import Data.Maybe (fromMaybe) 5 | import Data.Semigroup ((<>)) 6 | import qualified Data.Text as DT 7 | import qualified Data.Text as T 8 | import Options.Applicative hiding (Success) 9 | import System.Environment (lookupEnv) 10 | import Text.PrettyPrint.Boxes hiding ((<>)) 11 | import Text.Read (readMaybe) 12 | import Text.URI (URI, mkURI) 13 | import TodoApp.Request (Task) 14 | import qualified TodoApp.Request as TR 15 | 16 | newtype Opts = Opts {optCommand :: Command} 17 | 18 | data Command 19 | = Add String 20 | | Delete Int 21 | | Done Int 22 | | View 23 | | ViewAll 24 | | Reset 25 | 26 | main :: IO () 27 | main = do 28 | conn <- getConnection 29 | -- CLI options 30 | opts <- execParser optsParser 31 | -- Run the app 32 | runApp conn opts 33 | 34 | runApp :: TR.Connection -> Opts -> IO () 35 | runApp conn opts = do 36 | case optCommand opts of 37 | Add task -> do 38 | TR.runRequest conn (TR.Add task) 39 | putStrLn "Task added!" 40 | Delete id -> do 41 | TR.runRequest conn (TR.Delete id) 42 | putStrLn "Task deleted!" 43 | Done id -> do 44 | TR.runRequest conn (TR.Complete id) 45 | putStrLn "Task completed!" 46 | View -> do 47 | todo <- TR.runRequest conn TR.View 48 | mapM_ printTask todo 49 | ViewAll -> do 50 | todo <- TR.runRequest conn TR.ViewAll 51 | mapM_ printTask todo 52 | Reset -> do 53 | TR.runRequest conn TR.Reset 54 | putStrLn "Tasks cleared!" 55 | where 56 | printTask :: TR.Task -> IO () 57 | printTask v = do 58 | printBox 59 | -- Move the task row to the right by 2 spaces 60 | ( moveRight 61 | 2 62 | -- Prints `✓ ` 63 | (text (getStatusIcon (TR.done v) $ show (TR.id v))) 64 | <+> 65 | -- Prints task in a box whose width is `width` and 66 | -- height depends on the length of the taks message 67 | para left width (DT.unpack $ TR.task v) 68 | ) 69 | -- Print an extra line to separate two tasks 70 | printBox $ text " " 71 | 72 | -- \|Set the width of the box that displays the list of TODO's 73 | width :: Int 74 | width = 50 75 | 76 | getStatusIcon :: Bool -> String -> String 77 | getStatusIcon True _ = "[x] " 78 | getStatusIcon False id = "[" ++ id ++ "] " 79 | 80 | -- | Get `TR.Connection` to connect to the postgrest service 81 | getConnection :: IO TR.Connection 82 | getConnection = do 83 | unixSocketPath <- lookupEnv "PGRST_SERVER_UNIX_SOCKET" 84 | case unixSocketPath of 85 | Just path -> pure $ TR.UnixSocket path 86 | Nothing -> do 87 | todoUri <- lookupEnv "TODO_URI" 88 | postgrestHost <- lookupEnv "PGRST_SERVER_HOST" 89 | postgrestPort <- lookupEnv "PGRST_SERVER_PORT" 90 | let defaultUri = "http://" <> fromMaybe "localhost" postgrestHost <> ":" <> fromMaybe "3000" postgrestPort 91 | let uri = fromMaybe defaultUri todoUri 92 | TR.TCP <$> mkURI (T.pack uri) 93 | 94 | optsParser :: ParserInfo Opts 95 | optsParser = 96 | info 97 | (helper <*> versionOption <*> programOptions) 98 | ( fullDesc 99 | <> header 100 | "todo-app - A demo Haskell app showing the use of `flake-parts` to enable various dev workflows" 101 | ) 102 | where 103 | versionOption :: Parser (a -> a) 104 | versionOption = infoOption "0.0" (long "version" <> help "Show version") 105 | programOptions :: Parser Opts 106 | programOptions = 107 | Opts <$> hsubparser (addCommand <> deleteCommand <> doneCommand <> viewCommand <> viewAllCommand <> resetCommand) 108 | addCommand :: Mod CommandFields Command 109 | addCommand = 110 | command 111 | "add" 112 | (info addOptions (progDesc "Add a task")) 113 | addOptions :: Parser Command 114 | addOptions = 115 | Add 116 | <$> strArgument (metavar "Task" <> help "Task to add in TODO") 117 | deleteCommand :: Mod CommandFields Command 118 | deleteCommand = 119 | command 120 | "delete" 121 | (info deleteOptions (progDesc "Delete a task")) 122 | deleteOptions :: Parser Command 123 | deleteOptions = 124 | Delete 125 | <$> argument auto (metavar "Task_ID" <> help "ID of the task to delete from TODO") 126 | doneCommand :: Mod CommandFields Command 127 | doneCommand = 128 | command 129 | "done" 130 | (info doneOptions (progDesc "Mark a task as complete")) 131 | doneOptions :: Parser Command 132 | doneOptions = 133 | Done 134 | <$> argument auto (metavar "Task_ID" <> help "ID of the task to mark as complete") 135 | viewCommand :: Mod CommandFields Command 136 | viewCommand = 137 | command 138 | "view" 139 | (info (pure View) (progDesc "View list of pending TODOs")) 140 | -- TODO: make this an extension for view command, for example: view -a should print 141 | -- all tasks 142 | viewAllCommand :: Mod CommandFields Command 143 | viewAllCommand = 144 | command 145 | "viewAll" 146 | (info (pure ViewAll) (progDesc "View list of all TODOs")) 147 | resetCommand :: Mod CommandFields Command 148 | resetCommand = 149 | command 150 | "reset" 151 | (info (pure Reset) (progDesc "Clear the TODO list")) 152 | -------------------------------------------------------------------------------- /src/TodoApp/Request.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module TodoApp.Request 5 | ( -- * Task type 6 | Task (..), 7 | 8 | -- * Interacting with tasks 9 | Request (..), 10 | runRequest, 11 | Connection (..), 12 | ) 13 | where 14 | 15 | import Control.Lens ((&), (.~), (?~)) 16 | import Control.Monad (void) 17 | import Control.Monad.IO.Class (MonadIO) 18 | import Data.Aeson (Result, decode, fromJSON, object, (.=)) 19 | import qualified Data.Aeson as Aeson 20 | import Data.Aeson.Types (FromJSON) 21 | import Data.ByteString.Lazy.Internal (ByteString) 22 | import Data.Kind (Type) 23 | import Data.Maybe (fromJust, fromMaybe) 24 | import Data.String (IsString (fromString)) 25 | import Data.Text (Text, concat, pack) 26 | import GHC.Generics (Generic) 27 | import qualified Network.HTTP.Req as R 28 | import Text.URI (Authority (Authority), QueryParam (..), RText, RTextLabel (Host, PathPiece), URI, emptyURI, mkHost, mkPathPiece, mkQueryKey, mkQueryValue, mkScheme, mkURI) 29 | import Text.URI.Lens (queryParam, uriAuthority, uriPath, uriQuery, uriScheme) 30 | import Prelude hiding (concat) 31 | import qualified Network.HTTP.Client as HC 32 | import qualified Network.Socket as NS 33 | 34 | type TaskId = Int 35 | 36 | data Task = Task 37 | { id :: TaskId, 38 | done :: Bool, 39 | task :: Text 40 | } 41 | deriving stock (Generic, Show, Eq) 42 | deriving anyclass (FromJSON) 43 | 44 | data Request r where 45 | -- | Mark a task as complete 46 | Complete :: TaskId -> Request () 47 | -- | Return all tasks 48 | ViewAll :: Request [Task] 49 | -- | Return pending tasks 50 | View :: Request [Task] 51 | -- | Add a new task 52 | Add :: String -> Request () 53 | -- | Delete a task 54 | Delete :: TaskId -> Request () 55 | -- | Remove all tasks 56 | Reset :: Request () 57 | 58 | data Connection 59 | = TCP URI 60 | | UnixSocket FilePath 61 | 62 | createUnixSocketManager :: FilePath -> IO HC.Manager 63 | createUnixSocketManager socketPath = HC.newManager $ HC.defaultManagerSettings 64 | { HC.managerRawConnection = return $ \_ _ _ -> do 65 | sock <- NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol 66 | NS.connect sock (NS.SockAddrUnix socketPath) 67 | HC.socketConnection sock 8192 68 | } 69 | 70 | runRequest :: 71 | (MonadIO m, m ~ IO) => 72 | Connection -> 73 | Request a -> 74 | m a 75 | runRequest conn = \case 76 | Complete id -> complete id conn 77 | ViewAll -> viewAll conn 78 | View -> view conn 79 | Add task -> add task conn 80 | Delete id -> delete id conn 81 | Reset -> reset conn 82 | 83 | -- | Mark the item with id as done 84 | complete :: Int -> Connection -> IO () 85 | complete id conn = do 86 | let payload = 87 | object ["done" .= ("true" :: String)] 88 | q <- QueryParam <$> mkQueryKey "id" <*> mkQueryValue ("eq." <> pack (show id)) 89 | path <- traverse mkPathPiece ["todos"] 90 | void $ request (R.ReqBodyJson payload) R.PATCH path [q] conn 91 | 92 | -- | Return all the items in the table 93 | viewAll :: Connection -> IO [Task] 94 | viewAll conn = do 95 | path <- traverse mkPathPiece ["todos"] 96 | res <- request R.NoReqBody R.GET path [] conn 97 | let v = fromJSON $ fromMaybe (object []) $ decode res 98 | pure $ case v of 99 | Aeson.Success a -> a 100 | Aeson.Error e -> error e 101 | 102 | -- | Return pending items in the table 103 | view :: Connection -> IO [Task] 104 | view conn = do 105 | path <- traverse mkPathPiece ["todos"] 106 | q <- QueryParam <$> mkQueryKey "done" <*> mkQueryValue "is.false" 107 | res <- request R.NoReqBody R.GET path [q] conn 108 | let v = fromJSON $ fromMaybe (object []) $ decode res 109 | pure $ case v of 110 | Aeson.Success a -> a 111 | Aeson.Error e -> error e 112 | 113 | -- | Add a new task to the table 114 | add :: String -> Connection -> IO () 115 | add task conn = do 116 | let payload = 117 | object ["task" .= task] 118 | path <- traverse mkPathPiece ["todos"] 119 | void $ request (R.ReqBodyJson payload) R.POST path [] conn 120 | 121 | -- | Delete a TODO item with given id 122 | delete :: Int -> Connection -> IO () 123 | delete id conn = do 124 | path <- traverse mkPathPiece ["todos"] 125 | q <- QueryParam <$> mkQueryKey "id" <*> mkQueryValue ("eq." <> pack (show id)) 126 | void $ request R.NoReqBody R.DELETE path [q] conn 127 | 128 | -- | Remove all the TODO items from the table 129 | reset :: Connection -> IO () 130 | reset conn = do 131 | path <- traverse mkPathPiece ["todos"] 132 | _ <- request R.NoReqBody R.DELETE path [] conn 133 | -- Call a SQL function that sets the sequence to start from 1 134 | path <- traverse mkPathPiece ["rpc", "reset_id"] 135 | void $ request R.NoReqBody R.POST path [] conn 136 | 137 | -- TODO: Add more comments 138 | 139 | -- | Make a http request to postgrest service 140 | request :: 141 | ( R.HttpBodyAllowed (R.AllowsBody method) (R.ProvidesBody body), 142 | R.HttpMethod method, 143 | R.HttpBody body 144 | ) => 145 | body -> 146 | method -> 147 | [RText 'PathPiece] -> 148 | [QueryParam] -> 149 | Connection -> 150 | IO ByteString 151 | request body method paths qs conn = do 152 | httpConfig <- getHttpConfig conn 153 | R.runReq httpConfig $ do 154 | let uri = 155 | getURI conn 156 | & uriQuery .~ qs 157 | & uriPath .~ paths 158 | let (url, options) = fromJust $ R.useHttpURI uri 159 | r <- 160 | R.req 161 | method 162 | url 163 | body 164 | R.lbsResponse 165 | options -- options include the query parameters that help in filtering rows of a table 166 | let responseCode = R.responseStatusCode r :: Int 167 | if responseCode >= 200 && responseCode < 300 168 | then return $ R.responseBody r 169 | else error "Request failed" 170 | 171 | -- | Get the HTTP config given `Connection` 172 | getHttpConfig :: Connection -> IO R.HttpConfig 173 | getHttpConfig (TCP _) = pure R.defaultHttpConfig 174 | getHttpConfig (UnixSocket socketPath) = do 175 | socketManager <- createUnixSocketManager socketPath 176 | pure $ R.defaultHttpConfig { R.httpConfigAltManager = Just socketManager } 177 | 178 | -- | Get the URI of the postgrest service given `Connection` 179 | getURI :: Connection -> URI 180 | getURI (TCP u) = u 181 | -- Even though the connection is over unix socket, `req` expects a URL-like string, 182 | -- so we use a dummy hostname. 183 | getURI (UnixSocket _) = fromJust $ mkURI "http://localhost" 184 | -------------------------------------------------------------------------------- /todo-app.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: todo-app 3 | version: 0.1 4 | synopsis: TODO app using PostgREST web server 5 | 6 | license: MIT 7 | copyright: Copyright (c) 2023 Juspay 8 | author: Shivaraj B H 9 | category: Introduction 10 | homepage: https://github.com/juspay/todo-app 11 | bug-reports: https://github.com/juspay/todo-app/issues 12 | tested-with: GHC ==9.2.6 || ==9.2.7 13 | 14 | source-repository head 15 | type: git 16 | location: https://github.com/juspay/todo-app 17 | 18 | extra-source-files: 19 | LICENSE 20 | README.md 21 | 22 | executable todo-app 23 | other-modules: TodoApp.Request 24 | main-is: Main.hs 25 | default-extensions: 26 | BlockArguments 27 | DataKinds 28 | DeriveAnyClass 29 | DeriveGeneric 30 | DerivingStrategies 31 | KindSignatures 32 | OverloadedStrings 33 | OverloadedStrings 34 | ScopedTypeVariables 35 | 36 | build-depends: 37 | , aeson 38 | , base 39 | , boxes 40 | , bytestring 41 | , http-client 42 | , lens 43 | , modern-uri 44 | , network 45 | , optparse-applicative 46 | , req 47 | , text 48 | , vector 49 | 50 | hs-source-dirs: src 51 | default-language: Haskell2010 52 | --------------------------------------------------------------------------------