Implemented multi record handling

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,62 @@ 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"
+        originalTags <- fetch tagIds
+        let tags = zip tagIds tagNames
+                |> map (\(id, name) -> originalTags
+                    |> find (\tag -> tag.id == id)
+                    |> fromMaybe (newRecord |> set #taskId task.id)
+                    |> \tag -> buildTag tag name
+                )
+
+
         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 tags = names |> map (buildTag newRecord)
+
         task
             |> buildTask
+            |> updateField @"tags" tags
+            |> bubbleValidationResult #tags
             |> ifValid \case
-                Left task -> render NewView { .. } 
+                Left task -> render NewView { task }
-                Right task -> do
+                Right taskAndTags -> do
-                    task <- task |> createRecord
+                    (task, tags) <- withTransaction do
-                    setSuccessMessage "Task created"
+                        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 +90,34 @@ instance Controller TasksController where
 
 buildTask task = task
     |> fill @'["description"]
+    |> validateField #description nonEmpty
+
+buildTag :: Tag -> Text -> Tag
+buildTag tag name = tag
+    |> set #name name
+    |> 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/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,7 +1,7 @@
 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|
@@ -26,12 +26,19 @@ instance View IndexView where
                 [ breadcrumbLink "Tasks" TasksAction
                 ]
 
-renderTask :: Task -> Html
+renderTask :: Include "tags" Task -> Html
 renderTask task = [hsx|
     <tr>
         <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,14 @@
 module Web.View.Tasks.New where
 import Web.View.Prelude
+import Text.Blaze.Html.Renderer.Text
 
-data NewView = NewView { task :: Task }
+data NewView = NewView { task :: Include "tags" Task }
 
 instance View NewView where
     html NewView { .. } = [hsx|
         {breadcrumb}
         <h1>New Task</h1>
+
         {renderForm task}
     |]
         where
@@ -14,10 +16,30 @@ instance View NewView where
                 [ breadcrumbLink "Tasks" TasksAction
                 , breadcrumbText "New Task"
                 ]
-
+renderForm :: Include "tags" Task -> Html
-renderForm :: Task -> Html
 renderForm task = formFor task [hsx|
-    {(textField #description)}
+    {textField #description}
-    {submitButton}
 
+    <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 [newRecord] } in nestedFormFor field renderTagForm
+
+renderTagForm :: (?formContext :: FormContext Tag) => Html
+renderTagForm = [hsx|
+    {(textField #name) { disableLabel = True, placeholder = "Tag name" } }
 |]