diff --git a/Web/Controller/Tasks.hs b/Web/Controller/Tasks.hs index 5c44e13..e2858d4 100644 --- a/Web/Controller/Tasks.hs +++ b/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 { .. } - 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 +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 \ No newline at end of file diff --git a/Web/View/Tasks/Edit.hs b/Web/View/Tasks/Edit.hs index 6853914..907e741 100644 --- a/Web/View/Tasks/Edit.hs +++ b/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} - -|] \ No newline at end of file + ] \ No newline at end of file diff --git a/Web/View/Tasks/Index.hs b/Web/View/Tasks/Index.hs index 5f78343..70991b6 100644 --- a/Web/View/Tasks/Index.hs +++ b/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| {task.description} + {renderTags task.tags} Show Edit Delete -|] \ No newline at end of file +|] + +renderTags :: [Tag] -> Text +renderTags tags = + tags + |> map (.name) + |> intercalate ", " \ No newline at end of file diff --git a/Web/View/Tasks/New.hs b/Web/View/Tasks/New.hs index 36b7c45..12b48e4 100644 --- a/Web/View/Tasks/New.hs +++ b/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}

New Task

+ {renderForm task} |] where @@ -14,10 +16,30 @@ instance View NewView where [ breadcrumbLink "Tasks" TasksAction , breadcrumbText "New Task" ] - -renderForm :: Task -> Html +renderForm :: Include "tags" Task -> Html renderForm task = formFor task [hsx| - {(textField #description)} - {submitButton} + {textField #description} +
+ Tags + + {nestedFormFor #tags renderTagForm} +
+ + + + {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" } } |] \ No newline at end of file