Add values to tasks

Upgrade to v1.1.0

.envrc

@@ -0,0 +1,16 @@
+if ! has nix_direnv_version || ! nix_direnv_version 2.3.0; then
+    source_url "https://raw.githubusercontent.com/nix-community/nix-direnv/2.3.0/direnvrc" "sha256-Dmd+j63L84wuzgyjITIfSxSD57Tx7v51DMxVZOsiUD8="
+fi
+
+use flake . --impure --accept-flake-config
+
+# Include .env file if it exists locally. Use the .env file to load env vars that you don't want to commit to git
+if [ -f .env ]
+then
+    set -o allexport
+    source .env
+    set +o allexport
+fi
+# Add your env vars here
+#
+# E.g. export AWS_ACCESS_KEY_ID="XXXXX"

.ghci

@@ -1,4 +1,4 @@
 :set -XNoImplicitPrelude
-:def source readFile
-:source build/ihp-lib/applicationGhciConfig
-import IHP.Prelude
+:def loadFromIHP \file -> (System.Environment.getEnv "IHP_LIB") >>= (\ihpLib -> readFile (ihpLib <> "/" <> file))
+:loadFromIHP applicationGhciConfig
+import IHP.Prelude

.gitignore

@@ -1,5 +1,4 @@
 .DS_Store
-.envrc
 .idea
 tmp
 result
@@ -21,3 +20,8 @@ Config/client_session_key.aes
 
 # Ignore locally checked out IHP version
 IHP
+
+.devenv*
+devenv.local.nix
+.direnv
+.env

Application/Migration/1712249898.sql

@@ -0,0 +1 @@
+ALTER TABLE tags ADD COLUMN value TEXT NOT NULL;

Application/Schema.sql

@@ -6,7 +6,8 @@ CREATE TABLE tasks (
 CREATE TABLE tags (
     id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
     name TEXT NOT NULL,
-    task_id UUID NOT NULL
+    task_id UUID NOT NULL,
+    value TEXT NOT NULL
 );
 CREATE INDEX tags_task_id_index ON tags (task_id);
 ALTER TABLE tags ADD CONSTRAINT tags_ref_task_id FOREIGN KEY (task_id) REFERENCES tasks (id) ON DELETE NO ACTION;

README.md

@@ -0,0 +1,10 @@
+Example for Multi Record Forms
+
+Announced on https://github.com/digitallyinduced/ihp/releases/tag/v1.1.0
+
+## Installation
+
+```bash
+direnv allow
+devenv up
+```

Web/Controller/Tasks.hs

@@ -9,10 +9,13 @@ import Web.View.Tasks.Show
 instance Controller TasksController where
     action TasksAction = do
         tasks <- query @Task |> fetch
+                >>= collectionFetchRelated #tags
         render IndexView { .. }
 
     action NewTaskAction = do
-        let task = newRecord
+        let tags = [newRecord @Tag, newRecord @Tag]
+        let task = newRecord @Task
+                |> updateField @"tags" tags
         render NewView { .. }
 
     action ShowTaskAction { taskId } = do
@@ -21,28 +24,63 @@ instance Controller TasksController where
 
     action EditTaskAction { taskId } = do
         task <- fetch taskId
+                >>= fetchRelated #tags
         render EditView { .. }
 
     action UpdateTaskAction { taskId } = do
         task <- fetch taskId
+
+        let tagIds :: [Id Tag] = paramList "tags_id"
+        let tagNames :: [Text] = paramList "tags_name"
+        let tagValues :: [Text] = paramList "tags_value"
+        originalTags <- fetch tagIds
+        let tags = zip3 tagIds tagNames tagValues
+                |> map (\(id, name, value) -> originalTags
+                    |> find (\tag -> tag.id == id)
+                    |> fromMaybe (newRecord |> set #taskId task.id)
+                    |> \tag -> buildTag tag name value
+                )
+
         task
             |> buildTask
+            |> updateField @"tags" tags
+            |> bubbleValidationResult #tags
             |> ifValid \case
-                Left task -> render EditView { .. }
+                Left task -> do
+                    render EditView { task }
                 Right task -> do
-                    task <- task |> updateRecord
+                    (task, tags) <- withTransaction do
+                        task <- task
+                                |> clearTags
+                                |> updateRecord
+                        tags <- mapM updateOrCreateRecord tags
+                        pure (task, tags)
+
                     setSuccessMessage "Task updated"
                     redirectTo EditTaskAction { .. }
 
     action CreateTaskAction = do
         let task = newRecord @Task
+        let names :: [Text] = paramList "tags_name"
+        let values :: [Text] = paramList "tags_value"
+        let tags = zip names values |> map (\(name, value) -> buildTag newRecord name value)
+
         task
             |> buildTask
+            |> updateField @"tags" tags
+            |> bubbleValidationResult #tags
             |> ifValid \case
-                Left task -> render NewView { .. } 
-                Right task -> do
-                    task <- task |> createRecord
-                    setSuccessMessage "Task created"
+                Left task -> render NewView { task }
+                Right taskAndTags -> do
+                    (task, tags) <- withTransaction do
+                        task <- taskAndTags |> clearTags |> createRecord
+                        tags <- taskAndTags.tags
+                            |> map (set #taskId task.id)
+                            |> createMany
+
+                        pure (task, tags)
+                    
+                    setSuccessMessage "Task and Tags created"
                     redirectTo TasksAction
 
     action DeleteTaskAction { taskId } = do
@@ -53,3 +91,35 @@ instance Controller TasksController where
 
 buildTask task = task
     |> fill @'["description"]
+    |> validateField #description nonEmpty
+
+buildTag :: Tag -> Text -> Text -> Tag
+buildTag tag name value = tag
+    |> set #name name
+    |> set #value value
+    |> validateField #name nonEmpty
+
+-- | Adds a validation error to the record when any of the child records is invalid
+bubbleValidationResult :: forall fieldName record childRecord.
+    ( HasField "meta" record MetaBag
+    , SetField "meta" record MetaBag
+    , KnownSymbol fieldName
+    , HasField fieldName record [childRecord]
+    , HasField "meta" childRecord MetaBag
+    , SetField "meta" childRecord MetaBag
+    ) => Proxy fieldName -> record -> record
+bubbleValidationResult field record =
+        if isEmpty childAnnotations
+            then record
+            else record |> attachFailure field "Invalid records"
+    where
+        childAnnotations :: [(Text, Violation)]
+        childAnnotations = get field record
+            |> map (\record -> record.meta.annotations)
+            |> concat
+
+updateOrCreateRecord record | isNew record = createRecord record
+updateOrCreateRecord record = updateRecord record
+
+clearTags :: Include "tags" Task -> Task
+clearTags task = updateField @"tags" (newRecord @Task).tags task

Web/FrontController.hs

@@ -10,7 +10,7 @@ import Web.Controller.Static
 
 instance FrontController WebApplication where
     controllers = 
-        [ startPage WelcomeAction
+        [ startPage TasksAction
         -- Generator Marker
         , parseRoute @TasksController
         ]

Web/View/Tasks/Edit.hs

@@ -1,7 +1,8 @@
 module Web.View.Tasks.Edit where
 import Web.View.Prelude
+import Web.View.Tasks.New (renderForm)
 
-data EditView = EditView { task :: Task }
+data EditView = EditView { task :: Include "tags" Task }
 
 instance View EditView where
     html EditView { .. } = [hsx|
@@ -13,11 +14,4 @@ instance View EditView where
             breadcrumb = renderBreadcrumb
                 [ breadcrumbLink "Tasks" TasksAction
                 , breadcrumbText "Edit Task"
-                ]
-
-renderForm :: Task -> Html
-renderForm task = formFor task [hsx|
-    {(textField #description)}
-    {submitButton}
-
-|]
+                ]

Web/View/Tasks/Index.hs

@@ -1,13 +1,11 @@
 module Web.View.Tasks.Index where
 import Web.View.Prelude
 
-data IndexView = IndexView { tasks :: [Task]  }
+data IndexView = IndexView { tasks :: [Include "tags" Task]  }
 
 instance View IndexView where
     html IndexView { .. } = [hsx|
-        {breadcrumb}
-
-        <h1>Index<a href={pathTo NewTaskAction} class="btn btn-primary ms-4">+ New</a></h1>
+        <h1>Tasks<a href={pathTo NewTaskAction} class="btn btn-primary ms-4">+ New</a></h1>
         <div class="table-responsive">
             <table class="table">
                 <thead>
@@ -28,12 +26,19 @@ instance View IndexView where
                 [ breadcrumbLink "Tasks" TasksAction
                 ]
 
-renderTask :: Task -> Html
+renderTask :: Include "tags" Task -> Html
 renderTask task = [hsx|
     <tr>
-        <td>{task}</td>
+        <td>{task.description}</td>
+        <td>{renderTags task.tags}</td>
         <td><a href={ShowTaskAction task.id}>Show</a></td>
         <td><a href={EditTaskAction task.id} class="text-muted">Edit</a></td>
         <td><a href={DeleteTaskAction task.id} class="js-delete text-muted">Delete</a></td>
     </tr>
-|]
+|]
+
+renderTags :: [Tag] -> Text
+renderTags tags =
+    tags
+    |> map (.name)
+    |> intercalate ", "

Web/View/Tasks/New.hs

@@ -1,12 +1,15 @@
 module Web.View.Tasks.New where
-import Web.View.Prelude
 
-data NewView = NewView { task :: Task }
+import Web.View.Prelude
+import Text.Blaze.Html.Renderer.Text
+
+data NewView = NewView { task :: Include "tags" Task }
 
 instance View NewView where
     html NewView { .. } = [hsx|
         {breadcrumb}
         <h1>New Task</h1>
+
         {renderForm task}
     |]
         where
@@ -15,9 +18,31 @@ instance View NewView where
                 , breadcrumbText "New Task"
                 ]
 
-renderForm :: Task -> Html
+renderForm :: Include "tags" Task -> Html
 renderForm task = formFor task [hsx|
-    {(textField #description)}
-    {submitButton}
+    {textField #description}
 
-|]
+    <fieldset>
+        <legend>Tags</legend>
+
+        {nestedFormFor #tags renderTagForm}
+    </fieldset>
+
+    <button type="button" class="btn btn-light" data-prototype={prototypeFor #tags (newRecord @Tag)} onclick="this.insertAdjacentHTML('beforebegin', this.dataset.prototype)">Add Tag</button>
+
+    {submitButton}
+|]
+
+prototypeFor :: _ => _ -> _ -> Text
+prototypeFor field record =
+        cs $ renderHtml prototype
+    where
+        parentFormContext = ?formContext
+        prototype :: Html
+        prototype = let ?formContext = parentFormContext { model = parentFormContext.model |> set field [record] } in nestedFormFor field renderTagForm
+
+renderTagForm :: (?formContext :: FormContext Tag) => Html
+renderTagForm = [hsx|
+    {(textField #name) { disableLabel = True, placeholder = "Tag name" } }
+    {(textField #value) { disableLabel = True, placeholder = "Tag value" } }
+|]

default.nix

@@ -1,22 +1,9 @@
-let
-    ihp = builtins.fetchGit {
-        url = "https://github.com/digitallyinduced/ihp.git";
-        rev = "113ce378747ce129f293d5cef504acbb3bca44ca";
-    };
-    haskellEnv = import "${ihp}/NixSupport/default.nix" {
-        ihp = ihp;
-        haskellDeps = p: with p; [
-            cabal-install
-            base
-            wai
-            text
-            hlint
-            p.ihp
-        ];
-        otherDeps = p: with p; [
-            # Native dependencies, e.g. imagemagick
-        ];
-        projectPath = ./.;
-    };
-in
-    haskellEnv
+# For backwards compatibility using flake.nix
+(import
+    (
+        fetchTarball {
+            url = "https://github.com/edolstra/flake-compat/archive/35bb57c0c8d8b62bbfd284272c928ceb64ddbde9.tar.gz";
+            sha256 = "sha256:1prd9b1xx8c0sfwnyzkspplh30m613j42l1k789s521f4kv4c2z2";
+        }
+    )
+{ src = ./.; }).defaultNix

flake.lock

@@ -0,0 +1,315 @@
+{
+  "nodes": {
+    "devenv": {
+      "inputs": {
+        "flake-compat": "flake-compat",
+        "nix": "nix",
+        "nixpkgs": [
+          "ihp",
+          "nixpkgs"
+        ],
+        "pre-commit-hooks": "pre-commit-hooks"
+      },
+      "locked": {
+        "lastModified": 1686054274,
+        "narHash": "sha256-93aebyN7EMmeFFXisFIvp28UEbrozu79vd3pKPjvNR0=",
+        "owner": "cachix",
+        "repo": "devenv",
+        "rev": "c51a56bac8853c019241fe8d821c0a0d82422835",
+        "type": "github"
+      },
+      "original": {
+        "owner": "cachix",
+        "repo": "devenv",
+        "type": "github"
+      }
+    },
+    "flake-compat": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1673956053,
+        "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=",
+        "owner": "edolstra",
+        "repo": "flake-compat",
+        "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9",
+        "type": "github"
+      },
+      "original": {
+        "owner": "edolstra",
+        "repo": "flake-compat",
+        "type": "github"
+      }
+    },
+    "flake-parts": {
+      "inputs": {
+        "nixpkgs-lib": "nixpkgs-lib"
+      },
+      "locked": {
+        "lastModified": 1685662779,
+        "narHash": "sha256-cKDDciXGpMEjP1n6HlzKinN0H+oLmNpgeCTzYnsA2po=",
+        "owner": "hercules-ci",
+        "repo": "flake-parts",
+        "rev": "71fb97f0d875fd4de4994dfb849f2c75e17eb6c3",
+        "type": "github"
+      },
+      "original": {
+        "owner": "hercules-ci",
+        "repo": "flake-parts",
+        "type": "github"
+      }
+    },
+    "flake-utils": {
+      "locked": {
+        "lastModified": 1667395993,
+        "narHash": "sha256-nuEHfE/LcWyuSWnS8t12N1wc105Qtau+/OdUAjtQ0rA=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "5aed5285a952e0b949eb3ba02c12fa4fcfef535f",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
+    "gitignore": {
+      "inputs": {
+        "nixpkgs": [
+          "ihp",
+          "devenv",
+          "pre-commit-hooks",
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1660459072,
+        "narHash": "sha256-8DFJjXG8zqoONA1vXtgeKXy68KdJL5UaXR8NtVMUbx8=",
+        "owner": "hercules-ci",
+        "repo": "gitignore.nix",
+        "rev": "a20de23b925fd8264fd7fad6454652e142fd7f73",
+        "type": "github"
+      },
+      "original": {
+        "owner": "hercules-ci",
+        "repo": "gitignore.nix",
+        "type": "github"
+      }
+    },
+    "ihp": {
+      "inputs": {
+        "devenv": "devenv",
+        "flake-parts": "flake-parts",
+        "ihp-boilerplate": "ihp-boilerplate",
+        "nixpkgs": "nixpkgs",
+        "systems": "systems"
+      },
+      "locked": {
+        "lastModified": 1696078351,
+        "narHash": "sha256-B/sVdyHWN9Wm2ULkH5aLVLePXBdp0PNDYJkK/xMOvcs=",
+        "owner": "digitallyinduced",
+        "repo": "ihp",
+        "rev": "3f25e99f91f0664ba9782c82ae263d7a70206e4d",
+        "type": "github"
+      },
+      "original": {
+        "owner": "digitallyinduced",
+        "ref": "v1.1",
+        "repo": "ihp",
+        "type": "github"
+      }
+    },
+    "ihp-boilerplate": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1686165507,
+        "narHash": "sha256-ZaP8GfqjZDnMayPcvWxEqnZmRs4ixf5O5d1Ba867m4c=",
+        "owner": "digitallyinduced",
+        "repo": "ihp-boilerplate",
+        "rev": "ff63ce46b6fb68f1b8b3cdb0bdd6749f7ef1df93",
+        "type": "github"
+      },
+      "original": {
+        "owner": "digitallyinduced",
+        "ref": "nicolas/flake",
+        "repo": "ihp-boilerplate",
+        "type": "github"
+      }
+    },
+    "lowdown-src": {
+      "flake": false,
+      "locked": {
+        "lastModified": 1633514407,
+        "narHash": "sha256-Dw32tiMjdK9t3ETl5fzGrutQTzh2rufgZV4A/BbxuD4=",
+        "owner": "kristapsdz",
+        "repo": "lowdown",
+        "rev": "d2c2b44ff6c27b936ec27358a2653caaef8f73b8",
+        "type": "github"
+      },
+      "original": {
+        "owner": "kristapsdz",
+        "repo": "lowdown",
+        "type": "github"
+      }
+    },
+    "nix": {
+      "inputs": {
+        "lowdown-src": "lowdown-src",
+        "nixpkgs": [
+          "ihp",
+          "devenv",
+          "nixpkgs"
+        ],
+        "nixpkgs-regression": "nixpkgs-regression"
+      },
+      "locked": {
+        "lastModified": 1676545802,
+        "narHash": "sha256-EK4rZ+Hd5hsvXnzSzk2ikhStJnD63odF7SzsQ8CuSPU=",
+        "owner": "domenkozar",
+        "repo": "nix",
+        "rev": "7c91803598ffbcfe4a55c44ac6d49b2cf07a527f",
+        "type": "github"
+      },
+      "original": {
+        "owner": "domenkozar",
+        "ref": "relaxed-flakes",
+        "repo": "nix",
+        "type": "github"
+      }
+    },
+    "nixpkgs": {
+      "locked": {
+        "lastModified": 1681488673,
+        "narHash": "sha256-PmojOyePBNvbY3snYE7NAQHTLB53t7Ro+pgiJ4wPCuk=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "a95ed9fe764c3ba2bf2d2fa223012c379cd6b32e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "a95ed9fe764c3ba2bf2d2fa223012c379cd6b32e",
+        "type": "github"
+      }
+    },
+    "nixpkgs-lib": {
+      "locked": {
+        "dir": "lib",
+        "lastModified": 1685564631,
+        "narHash": "sha256-8ywr3AkblY4++3lIVxmrWZFzac7+f32ZEhH/A8pNscI=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "4f53efe34b3a8877ac923b9350c874e3dcd5dc0a",
+        "type": "github"
+      },
+      "original": {
+        "dir": "lib",
+        "owner": "NixOS",
+        "ref": "nixos-unstable",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "nixpkgs-regression": {
+      "locked": {
+        "lastModified": 1643052045,
+        "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2",
+        "type": "github"
+      }
+    },
+    "nixpkgs-stable": {
+      "locked": {
+        "lastModified": 1678872516,
+        "narHash": "sha256-/E1YwtMtFAu2KUQKV/1+KFuReYPANM2Rzehk84VxVoc=",
+        "owner": "NixOS",
+        "repo": "nixpkgs",
+        "rev": "9b8e5abb18324c7fe9f07cb100c3cd4a29cda8b8",
+        "type": "github"
+      },
+      "original": {
+        "owner": "NixOS",
+        "ref": "nixos-22.11",
+        "repo": "nixpkgs",
+        "type": "github"
+      }
+    },
+    "pre-commit-hooks": {
+      "inputs": {
+        "flake-compat": [
+          "ihp",
+          "devenv",
+          "flake-compat"
+        ],
+        "flake-utils": "flake-utils",
+        "gitignore": "gitignore",
+        "nixpkgs": [
+          "ihp",
+          "devenv",
+          "nixpkgs"
+        ],
+        "nixpkgs-stable": "nixpkgs-stable"
+      },
+      "locked": {
+        "lastModified": 1682596858,
+        "narHash": "sha256-Hf9XVpqaGqe/4oDGr30W8HlsWvJXtMsEPHDqHZA6dDg=",
+        "owner": "cachix",
+        "repo": "pre-commit-hooks.nix",
+        "rev": "fb58866e20af98779017134319b5663b8215d912",
+        "type": "github"
+      },
+      "original": {
+        "owner": "cachix",
+        "repo": "pre-commit-hooks.nix",
+        "type": "github"
+      }
+    },
+    "root": {
+      "inputs": {
+        "devenv": [
+          "ihp",
+          "devenv"
+        ],
+        "flake-parts": [
+          "ihp",
+          "flake-parts"
+        ],
+        "ihp": "ihp",
+        "nixpkgs": [
+          "ihp",
+          "nixpkgs"
+        ],
+        "systems": [
+          "ihp",
+          "systems"
+        ]
+      }
+    },
+    "systems": {
+      "locked": {
+        "lastModified": 1681028828,
+        "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=",
+        "owner": "nix-systems",
+        "repo": "default",
+        "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e",
+        "type": "github"
+      },
+      "original": {
+        "owner": "nix-systems",
+        "repo": "default",
+        "type": "github"
+      }
+    }
+  },
+  "root": "root",
+  "version": 7
+}

flake.nix

@@ -0,0 +1,38 @@
+{
+    inputs = {
+        # Here you can adjust the IHP version of your project
+        # You can find new releases at https://github.com/digitallyinduced/ihp/releases
+        ihp.url = "github:digitallyinduced/ihp/v1.1";
+        nixpkgs.follows = "ihp/nixpkgs";
+        flake-parts.follows = "ihp/flake-parts";
+        devenv.follows = "ihp/devenv";
+        systems.follows = "ihp/systems";
+    };
+
+    outputs = inputs@{ ihp, flake-parts, systems, ... }:
+        flake-parts.lib.mkFlake { inherit inputs; } {
+
+            systems = import systems;
+            imports = [ ihp.flakeModules.default ];
+
+            perSystem = { pkgs, ... }: {
+                ihp = {
+                    enable = true;
+                    projectPath = ./.;
+                    packages = with pkgs; [
+                        # Native dependencies, e.g. imagemagick
+                    ];
+                    haskellPackages = p: with p; [
+                        # Haskell dependencies go here
+                        p.ihp
+                        cabal-install
+                        base
+                        wai
+                        text
+                        hlint
+                    ];
+                };
+            };
+
+        };
+}

start

@@ -1,29 +0,0 @@
-#!/usr/bin/env bash
-# Script to start the local dev server
-
-set -e
-
-# On macOS the default max count of open files is 256. IHP needs atleast 1024 to run well.
-#
-# The wai-static-middleware sometimes doesn't close it's file handles directly (likely because of it's use of lazy bytestrings)
-# and then we usually hit the file limit of 256 at some point. With 1024 the limit is usually never hit as the GC kicks in earlier
-# and will close the remaining lazy bytestring handles.
-if [[ $OSTYPE == 'darwin'* ]]; then
-    ulimit -n 4096
-fi
-
-# Unless the RunDevServer binary is available, we rebuild the .envrc cache with nix-shell
-# and config cachix for using our binary cache
-command -v RunDevServer >/dev/null 2>&1 \
-    || { echo "PATH_add $(nix-shell -j auto --cores 0 --run 'printf %q $PATH')" > .envrc; }
-
-# Now we have to load the PATH variable from the .envrc cache
-direnv allow
-eval "$(direnv hook bash)"
-eval "$(direnv export bash)"
-
-# You can define custom env vars here:
-# export CUSTOM_ENV_VAR=".."
-
-# Finally start the dev server
-RunDevServer