forked from janek/compareware
Rename Tasks to Items and fix schema
This commit is contained in:
parent
3ae07c38f7
commit
be404dc8d0
20
App.cabal
20
App.cabal
|
@ -7,14 +7,14 @@
|
||||||
-- This cabal file is inside your project as some haskell tools only work when there's a cabal file. It's not actually used for anything besides providing support for haskell tools.
|
-- This cabal file is inside your project as some haskell tools only work when there's a cabal file. It's not actually used for anything besides providing support for haskell tools.
|
||||||
--
|
--
|
||||||
|
|
||||||
name: App
|
name: CompareWare
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
-- synopsis:
|
-- synopsis:
|
||||||
-- description:
|
-- description:
|
||||||
license: AllRightsReserved
|
license: GNU GPLv3
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Developers
|
author: CompareWare Developers
|
||||||
maintainer: developers@example.com
|
maintainer: hello@compareware.org
|
||||||
-- copyright:
|
-- copyright:
|
||||||
-- category:
|
-- category:
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
|
@ -25,10 +25,12 @@ executable App
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
build-depends:
|
build-depends:
|
||||||
ihp,
|
ihp
|
||||||
base,
|
, base
|
||||||
wai,
|
, wai
|
||||||
text
|
, text
|
||||||
|
, http-conduit
|
||||||
|
, aeson
|
||||||
hs-source-dirs: .
|
hs-source-dirs: .
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
extensions:
|
extensions:
|
||||||
|
@ -68,4 +70,4 @@ executable App
|
||||||
, FunctionalDependencies
|
, FunctionalDependencies
|
||||||
, PartialTypeSignatures
|
, PartialTypeSignatures
|
||||||
, StandaloneDeriving
|
, StandaloneDeriving
|
||||||
, DerivingVia
|
, DerivingVia
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
CREATE TABLE tasks (
|
CREATE TABLE items (
|
||||||
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
|
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
|
||||||
description TEXT NOT NULL
|
description TEXT NOT NULL
|
||||||
);
|
);
|
||||||
CREATE TABLE tags (
|
CREATE TABLE tags (
|
||||||
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
|
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
|
||||||
name TEXT NOT NULL,
|
name TEXT NOT NULL,
|
||||||
task_id UUID NOT NULL
|
item_id UUID NOT NULL
|
||||||
);
|
);
|
||||||
CREATE INDEX tags_task_id_index ON tags (task_id);
|
CREATE INDEX tags_item_id_index ON tags (item_id);
|
||||||
ALTER TABLE tags ADD CONSTRAINT tags_ref_task_id FOREIGN KEY (task_id) REFERENCES tasks (id) ON DELETE NO ACTION;
|
ALTER TABLE tags ADD CONSTRAINT tags_ref_item_id FOREIGN KEY (item_id) REFERENCES items (id) ON DELETE NO ACTION;
|
||||||
|
|
|
@ -0,0 +1,21 @@
|
||||||
|
ALTER TABLE tags DROP COLUMN item_id;
|
||||||
|
ALTER TABLE tags ADD COLUMN item_id TEXT NOT NULL;
|
||||||
|
ALTER TABLE tags ADD COLUMN created_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL;
|
||||||
|
ALTER TABLE tags ADD COLUMN updated_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL;
|
||||||
|
DROP TABLE items;
|
||||||
|
CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$BEGIN
|
||||||
|
NEW.updated_at = NOW();
|
||||||
|
RETURN NEW;
|
||||||
|
END;$$ language PLPGSQL;
|
||||||
|
CREATE TABLE items (
|
||||||
|
wikidataid TEXT NOT NULL,
|
||||||
|
description TEXT NOT NULL,
|
||||||
|
created_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL,
|
||||||
|
updated_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL
|
||||||
|
);
|
||||||
|
CREATE INDEX tags_item_id_index ON tags (item_id);
|
||||||
|
CREATE INDEX tags_created_at_index ON tags (created_at);
|
||||||
|
CREATE TRIGGER update_tags_updated_at BEFORE UPDATE ON tags FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();
|
||||||
|
CREATE INDEX items_created_at_index ON items (created_at);
|
||||||
|
CREATE TRIGGER update_items_updated_at BEFORE UPDATE ON items FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();
|
||||||
|
ALTER TABLE tags ADD CONSTRAINT tags_ref_item_id FOREIGN KEY (item_id) REFERENCES items (id) ON DELETE CASCADE;
|
|
@ -0,0 +1,17 @@
|
||||||
|
|
||||||
|
CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$BEGIN
|
||||||
|
NEW.updated_at = NOW();
|
||||||
|
RETURN NEW;
|
||||||
|
END;$$ language PLPGSQL;
|
||||||
|
CREATE TABLE items (
|
||||||
|
wikidataid TEXT NOT NULL,
|
||||||
|
description TEXT NOT NULL,
|
||||||
|
created_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL,
|
||||||
|
updated_at TIMESTAMP WITH TIME ZONE DEFAULT now() NOT NULL
|
||||||
|
);
|
||||||
|
CREATE INDEX tags_item_id_index ON tags (item_id);
|
||||||
|
CREATE INDEX tags_created_at_index ON tags (created_at);
|
||||||
|
CREATE TRIGGER update_tags_updated_at BEFORE UPDATE ON tags FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();
|
||||||
|
CREATE INDEX items_created_at_index ON items (created_at);
|
||||||
|
CREATE TRIGGER update_items_updated_at BEFORE UPDATE ON items FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();
|
||||||
|
ALTER TABLE tags ADD CONSTRAINT tags_ref_item_id FOREIGN KEY (item_id) REFERENCES items (id) ON DELETE CASCADE;
|
|
@ -0,0 +1 @@
|
||||||
|
ALTER TABLE tags ADD CONSTRAINT tags_ref_item_id FOREIGN KEY (item_id) REFERENCES items (id) ON DELETE CASCADE;
|
|
@ -0,0 +1 @@
|
||||||
|
ALTER TABLE tags ADD CONSTRAINT tags_ref_item_id FOREIGN KEY (item_id) REFERENCES items (wikidata_id) ON DELETE CASCADE;
|
|
@ -0,0 +1,2 @@
|
||||||
|
ALTER TABLE items ADD CONSTRAINT items_wikidata_id_key UNIQUE(wikidata_id);
|
||||||
|
ALTER TABLE tags ADD CONSTRAINT tags_ref_item_id FOREIGN KEY (item_id) REFERENCES items (wikidata_id) ON DELETE CASCADE;
|
|
@ -0,0 +1,4 @@
|
||||||
|
ALTER TABLE items ADD COLUMN id UUID DEFAULT uuid_generate_v4() NOT NULL;
|
||||||
|
ALTER TABLE tags DROP COLUMN item_id;
|
||||||
|
ALTER TABLE tags ADD COLUMN item_id UUID NOT NULL;
|
||||||
|
ALTER TABLE items ADD CONSTRAINT items_wikidata_id_key UNIQUE(wikidata_id);
|
|
@ -0,0 +1,2 @@
|
||||||
|
CREATE INDEX tags_item_id_index ON tags (item_id);
|
||||||
|
ALTER TABLE tags ADD CONSTRAINT tags_ref_item_id FOREIGN KEY (item_id) REFERENCES items (id) ON DELETE CASCADE;
|
|
@ -0,0 +1 @@
|
||||||
|
ALTER TABLE items ALTER COLUMN description SET DEFAULT '';
|
|
@ -1,13 +1,28 @@
|
||||||
|
CREATE FUNCTION set_updated_at_to_now() RETURNS TRIGGER AS $$
|
||||||
|
BEGIN
|
||||||
|
NEW.updated_at = NOW();
|
||||||
|
RETURN NEW;
|
||||||
|
END;
|
||||||
|
$$ language plpgsql;
|
||||||
-- Your database schema. Use the Schema Designer at http://localhost:8001/ to add some tables.
|
-- Your database schema. Use the Schema Designer at http://localhost:8001/ to add some tables.
|
||||||
CREATE TABLE tasks (
|
CREATE TABLE items (
|
||||||
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
|
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
|
||||||
description TEXT NOT NULL
|
wikidata_id TEXT NOT NULL UNIQUE,
|
||||||
|
description TEXT DEFAULT '' NOT NULL,
|
||||||
|
created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,
|
||||||
|
updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL
|
||||||
);
|
);
|
||||||
CREATE TABLE tags (
|
CREATE TABLE tags (
|
||||||
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
|
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
|
||||||
|
item_id UUID NOT NULL,
|
||||||
name TEXT NOT NULL,
|
name TEXT NOT NULL,
|
||||||
task_id UUID NOT NULL,
|
value TEXT NOT NULL,
|
||||||
value TEXT NOT NULL
|
created_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL,
|
||||||
|
updated_at TIMESTAMP WITH TIME ZONE DEFAULT NOW() NOT NULL
|
||||||
);
|
);
|
||||||
CREATE INDEX tags_task_id_index ON tags (task_id);
|
CREATE INDEX tags_item_id_index ON tags (item_id);
|
||||||
ALTER TABLE tags ADD CONSTRAINT tags_ref_task_id FOREIGN KEY (task_id) REFERENCES tasks (id) ON DELETE NO ACTION;
|
CREATE INDEX tags_created_at_index ON tags (created_at);
|
||||||
|
CREATE TRIGGER update_tags_updated_at BEFORE UPDATE ON tags FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();
|
||||||
|
CREATE INDEX items_created_at_index ON items (created_at);
|
||||||
|
CREATE TRIGGER update_items_updated_at BEFORE UPDATE ON items FOR EACH ROW EXECUTE FUNCTION set_updated_at_to_now();
|
||||||
|
ALTER TABLE tags ADD CONSTRAINT tags_ref_item_id FOREIGN KEY (item_id) REFERENCES items (id) ON DELETE CASCADE;
|
||||||
|
|
14
README.md
14
README.md
|
@ -1,5 +1,8 @@
|
||||||
# [CompareWare](https://compareware.org)
|
# [CompareWare](https://compareware.org)
|
||||||
|
|
||||||
|
This application is still a prototype,
|
||||||
|
with only a landing page publicly available thus far.
|
||||||
|
|
||||||
## Use-Cases
|
## Use-Cases
|
||||||
- Authorised users can create `Items`: Working, no authorisations
|
- Authorised users can create `Items`: Working, no authorisations
|
||||||
- `Items` can have `Tags`: Implemented
|
- `Items` can have `Tags`: Implemented
|
||||||
|
@ -26,11 +29,9 @@ and normalizes the schema.
|
||||||
|
|
||||||
![CompareWare Overview Entity Relationship Diagram](compareware-erd.png)
|
![CompareWare Overview Entity Relationship Diagram](compareware-erd.png)
|
||||||
|
|
||||||
Of course, every many-to-many relationship needs another table
|
For a fully normalized and implementable view,
|
||||||
to be represented in a normalized well,
|
every many-to-many relationship needs another table
|
||||||
which the diagram of the actual structure used in the code illustrates:
|
which will be visible in a diagram generated from the [schema](./Application/Schema.sql).
|
||||||
|
|
||||||
TODO
|
|
||||||
|
|
||||||
## Developer Setup
|
## Developer Setup
|
||||||
|
|
||||||
|
@ -38,3 +39,6 @@ TODO
|
||||||
direnv allow
|
direnv allow
|
||||||
devenv up
|
devenv up
|
||||||
```
|
```
|
||||||
|
|
||||||
|
Open up http://localhost:8000 and you can create,
|
||||||
|
edit and delete items with key-value tags.
|
||||||
|
|
|
@ -0,0 +1,183 @@
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
module Web.Controller.Items where
|
||||||
|
|
||||||
|
import Data.Aeson
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Network.HTTP.Simple (httpJSON, getResponseBody, parseRequest)
|
||||||
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
|
||||||
|
import Web.Controller.Prelude
|
||||||
|
import Web.View.Items.Index
|
||||||
|
import Web.View.Items.New
|
||||||
|
import Web.View.Items.Edit
|
||||||
|
import Web.View.Items.Show
|
||||||
|
|
||||||
|
|
||||||
|
instance Controller ItemsController where
|
||||||
|
action ItemsAction = do
|
||||||
|
items <- query @Item |> fetch
|
||||||
|
>>= collectionFetchRelated #tags
|
||||||
|
render IndexView { .. }
|
||||||
|
|
||||||
|
action NewItemAction = do
|
||||||
|
let tags = [newRecord @Tag, newRecord @Tag]
|
||||||
|
let item = newRecord @Item
|
||||||
|
|> updateField @"tags" tags
|
||||||
|
render NewView { .. }
|
||||||
|
|
||||||
|
action ShowItemAction { itemId } = do
|
||||||
|
item <- fetch itemId
|
||||||
|
render ShowView { .. }
|
||||||
|
|
||||||
|
action EditItemAction { itemId } = do
|
||||||
|
item <- fetch itemId
|
||||||
|
>>= fetchRelated #tags
|
||||||
|
render EditView { .. }
|
||||||
|
|
||||||
|
action UpdateItemAction { itemId } = do
|
||||||
|
item <- fetch itemId
|
||||||
|
|
||||||
|
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 #itemId item.id)
|
||||||
|
|> \tag -> buildTag tag name value
|
||||||
|
)
|
||||||
|
|
||||||
|
item
|
||||||
|
|> buildItem
|
||||||
|
|> updateField @"tags" tags
|
||||||
|
|> bubbleValidationResult #tags
|
||||||
|
|> ifValid \case
|
||||||
|
Left item -> do
|
||||||
|
render EditView { item }
|
||||||
|
Right item -> do
|
||||||
|
(item, tags) <- withTransaction do
|
||||||
|
item <- item
|
||||||
|
|> clearTags
|
||||||
|
|> updateRecord
|
||||||
|
tags <- mapM updateOrCreateRecord tags
|
||||||
|
pure (item, tags)
|
||||||
|
|
||||||
|
setSuccessMessage "Item updated"
|
||||||
|
redirectTo EditItemAction { .. }
|
||||||
|
|
||||||
|
action CreateItemAction = do
|
||||||
|
let item = newRecord @Item
|
||||||
|
let names :: [Text] = paramList "tags_name"
|
||||||
|
let values :: [Text] = paramList "tags_value"
|
||||||
|
let tags = zip names values |> map (\(name, value) -> buildTag newRecord name value)
|
||||||
|
|
||||||
|
-- users <- fetchItems -- Assuming this is your function that returns [User]
|
||||||
|
-- liftIO $ print users
|
||||||
|
-- renderPlain "Check your console!"
|
||||||
|
|
||||||
|
item
|
||||||
|
|> buildItem
|
||||||
|
|> updateField @"tags" tags
|
||||||
|
|> bubbleValidationResult #tags
|
||||||
|
|> ifValid \case
|
||||||
|
Left item -> render NewView { item }
|
||||||
|
Right itemAndTags -> do
|
||||||
|
(item, tags) <- withTransaction do
|
||||||
|
item <- itemAndTags |> clearTags |> createRecord
|
||||||
|
tags <- itemAndTags.tags
|
||||||
|
|> map (set #itemId item.id)
|
||||||
|
|> createMany
|
||||||
|
|
||||||
|
pure (item, tags)
|
||||||
|
|
||||||
|
setSuccessMessage "Item and Tags created"
|
||||||
|
redirectTo ItemsAction
|
||||||
|
|
||||||
|
action DeleteItemAction { itemId } = do
|
||||||
|
item <- fetch itemId
|
||||||
|
deleteRecord item
|
||||||
|
setSuccessMessage "Item deleted"
|
||||||
|
redirectTo ItemsAction
|
||||||
|
|
||||||
|
buildItem item = item
|
||||||
|
|> fill @'["description"]
|
||||||
|
|> fill @'["wikidataId"]
|
||||||
|
|> validateField #wikidataId 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" Item -> Item
|
||||||
|
clearTags item = updateField @"tags" (newRecord @Item).tags item
|
||||||
|
|
||||||
|
|
||||||
|
-- data ApiResponse = ApiResponse
|
||||||
|
-- { users :: [Item] }
|
||||||
|
--
|
||||||
|
-- instance FromJSON Item where
|
||||||
|
-- parseJSON = withObject "Item" $ \v -> do
|
||||||
|
-- let item = newRecord @Item
|
||||||
|
-- name <- v .: "name"
|
||||||
|
-- -- address <- v .: "address"
|
||||||
|
-- -- city <- address .: "city"
|
||||||
|
-- newRecord @Item
|
||||||
|
-- |> set #description name
|
||||||
|
--
|
||||||
|
-- instance FromJSON ApiResponse where
|
||||||
|
-- parseJSON = withObject "ApiResponse" $ \v -> ApiResponse
|
||||||
|
-- <$> v .: "users"
|
||||||
|
|
||||||
|
-- Example function to fetch and parse JSON
|
||||||
|
-- fetchItems :: [Item]
|
||||||
|
-- fetchItems = do
|
||||||
|
-- request <- parseRequest "GET https://www.wikidata.org/w/api.php?action=wbgetentities&ids=Q19675&languages=en&format=json" -- http://localhost:8000/Q19675.json
|
||||||
|
-- response <- httpJSON request
|
||||||
|
-- jsonData <- getResponseBody response
|
||||||
|
-- let maybeValue = decodeStrict (cs jsonData) :: Maybe Value
|
||||||
|
-- -- let apiResponse = getResponseBody response :: ApiResponse
|
||||||
|
-- -- users apiResponse
|
||||||
|
-- case maybeValue of
|
||||||
|
-- Just value -> do
|
||||||
|
-- case extractItemFromJson value of
|
||||||
|
-- Just item -> do
|
||||||
|
-- item <- item |> createRecord
|
||||||
|
-- redirectTo ShowItemAction { itemId = get #id item }
|
||||||
|
-- Nothing -> renderPlain "Failed to extract Item data from JSON"
|
||||||
|
-- Nothing -> renderPlain "Failed to parse JSON data"
|
||||||
|
--
|
||||||
|
--
|
||||||
|
-- extractItemFromJson :: Value -> Maybe Item
|
||||||
|
-- extractItemFromJson value = do
|
||||||
|
-- object <- case value of
|
||||||
|
-- Object obj -> Just obj
|
||||||
|
-- _ -> Nothing
|
||||||
|
-- itemId <- object .: "itemId"
|
||||||
|
-- itemName <- object .: "itemName" >>= parseJSON
|
||||||
|
--
|
||||||
|
-- pure Item { id = itemId, description = itemName }
|
|
@ -1,125 +0,0 @@
|
||||||
module Web.Controller.Tasks where
|
|
||||||
|
|
||||||
import Web.Controller.Prelude
|
|
||||||
import Web.View.Tasks.Index
|
|
||||||
import Web.View.Tasks.New
|
|
||||||
import Web.View.Tasks.Edit
|
|
||||||
import Web.View.Tasks.Show
|
|
||||||
|
|
||||||
instance Controller TasksController where
|
|
||||||
action TasksAction = do
|
|
||||||
tasks <- query @Task |> fetch
|
|
||||||
>>= collectionFetchRelated #tags
|
|
||||||
render IndexView { .. }
|
|
||||||
|
|
||||||
action NewTaskAction = do
|
|
||||||
let tags = [newRecord @Tag, newRecord @Tag]
|
|
||||||
let task = newRecord @Task
|
|
||||||
|> updateField @"tags" tags
|
|
||||||
render NewView { .. }
|
|
||||||
|
|
||||||
action ShowTaskAction { taskId } = do
|
|
||||||
task <- fetch taskId
|
|
||||||
render ShowView { .. }
|
|
||||||
|
|
||||||
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 -> do
|
|
||||||
render EditView { task }
|
|
||||||
Right task -> do
|
|
||||||
(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 { 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
|
|
||||||
task <- fetch taskId
|
|
||||||
deleteRecord task
|
|
||||||
setSuccessMessage "Task deleted"
|
|
||||||
redirectTo TasksAction
|
|
||||||
|
|
||||||
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
|
|
|
@ -5,14 +5,14 @@ import Web.Controller.Prelude
|
||||||
import Web.View.Layout (defaultLayout)
|
import Web.View.Layout (defaultLayout)
|
||||||
|
|
||||||
-- Controller Imports
|
-- Controller Imports
|
||||||
import Web.Controller.Tasks
|
import Web.Controller.Items
|
||||||
import Web.Controller.Static
|
import Web.Controller.Static
|
||||||
|
|
||||||
instance FrontController WebApplication where
|
instance FrontController WebApplication where
|
||||||
controllers =
|
controllers =
|
||||||
[ startPage TasksAction
|
[ startPage ItemsAction
|
||||||
-- Generator Marker
|
-- Generator Marker
|
||||||
, parseRoute @TasksController
|
, parseRoute @ItemsController
|
||||||
]
|
]
|
||||||
|
|
||||||
instance InitControllerContext WebApplication where
|
instance InitControllerContext WebApplication where
|
||||||
|
|
|
@ -5,5 +5,5 @@ import Web.Types
|
||||||
|
|
||||||
-- Generator Marker
|
-- Generator Marker
|
||||||
instance AutoRoute StaticController
|
instance AutoRoute StaticController
|
||||||
instance AutoRoute TasksController
|
instance AutoRoute ItemsController
|
||||||
|
|
||||||
|
|
16
Web/Types.hs
16
Web/Types.hs
|
@ -9,12 +9,12 @@ data WebApplication = WebApplication deriving (Eq, Show)
|
||||||
|
|
||||||
data StaticController = WelcomeAction deriving (Eq, Show, Data)
|
data StaticController = WelcomeAction deriving (Eq, Show, Data)
|
||||||
|
|
||||||
data TasksController
|
data ItemsController
|
||||||
= TasksAction
|
= ItemsAction
|
||||||
| NewTaskAction
|
| NewItemAction
|
||||||
| ShowTaskAction { taskId :: !(Id Task) }
|
| ShowItemAction { itemId :: !(Id Item) }
|
||||||
| CreateTaskAction
|
| CreateItemAction
|
||||||
| EditTaskAction { taskId :: !(Id Task) }
|
| EditItemAction { itemId :: !(Id Item) }
|
||||||
| UpdateTaskAction { taskId :: !(Id Task) }
|
| UpdateItemAction { itemId :: !(Id Item) }
|
||||||
| DeleteTaskAction { taskId :: !(Id Task) }
|
| DeleteItemAction { itemId :: !(Id Item) }
|
||||||
deriving (Eq, Show, Data)
|
deriving (Eq, Show, Data)
|
||||||
|
|
|
@ -0,0 +1,17 @@
|
||||||
|
module Web.View.Items.Edit where
|
||||||
|
import Web.View.Prelude
|
||||||
|
import Web.View.Items.New (renderForm)
|
||||||
|
|
||||||
|
data EditView = EditView { item :: Include "tags" Item }
|
||||||
|
|
||||||
|
instance View EditView where
|
||||||
|
html EditView { .. } = [hsx|
|
||||||
|
{breadcrumb}
|
||||||
|
<h1>Edit Item</h1>
|
||||||
|
{renderForm item}
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
breadcrumb = renderBreadcrumb
|
||||||
|
[ breadcrumbLink "Items" ItemsAction
|
||||||
|
, breadcrumbText "Edit Item"
|
||||||
|
]
|
|
@ -1,39 +1,39 @@
|
||||||
module Web.View.Tasks.Index where
|
module Web.View.Items.Index where
|
||||||
import Web.View.Prelude
|
import Web.View.Prelude
|
||||||
|
|
||||||
data IndexView = IndexView { tasks :: [Include "tags" Task] }
|
data IndexView = IndexView { items :: [Include "tags" Item] }
|
||||||
|
|
||||||
instance View IndexView where
|
instance View IndexView where
|
||||||
html IndexView { .. } = [hsx|
|
html IndexView { .. } = [hsx|
|
||||||
<h1>Tasks<a href={pathTo NewTaskAction} class="btn btn-primary ms-4">+ New</a></h1>
|
<h1>Items<a href={pathTo NewItemAction} class="btn btn-primary ms-4">+ New</a></h1>
|
||||||
<div class="table-responsive">
|
<div class="table-responsive">
|
||||||
<table class="table">
|
<table class="table">
|
||||||
<thead>
|
<thead>
|
||||||
<tr>
|
<tr>
|
||||||
<th>Task</th>
|
<th>Item</th>
|
||||||
<th></th>
|
<th></th>
|
||||||
<th></th>
|
<th></th>
|
||||||
<th></th>
|
<th></th>
|
||||||
</tr>
|
</tr>
|
||||||
</thead>
|
</thead>
|
||||||
<tbody>{forEach tasks renderTask}</tbody>
|
<tbody>{forEach items renderItem}</tbody>
|
||||||
</table>
|
</table>
|
||||||
|
|
||||||
</div>
|
</div>
|
||||||
|]
|
|]
|
||||||
where
|
where
|
||||||
breadcrumb = renderBreadcrumb
|
breadcrumb = renderBreadcrumb
|
||||||
[ breadcrumbLink "Tasks" TasksAction
|
[ breadcrumbLink "Items" ItemsAction
|
||||||
]
|
]
|
||||||
|
|
||||||
renderTask :: Include "tags" Task -> Html
|
renderItem :: Include "tags" Item -> Html
|
||||||
renderTask task = [hsx|
|
renderItem item = [hsx|
|
||||||
<tr>
|
<tr>
|
||||||
<td>{task.description}</td>
|
<td>{item.description}</td>
|
||||||
<td>{renderTags task.tags}</td>
|
<td>{renderTags item.tags}</td>
|
||||||
<td><a href={ShowTaskAction task.id}>Show</a></td>
|
<td><a href={ShowItemAction item.id}>Show</a></td>
|
||||||
<td><a href={EditTaskAction task.id} class="text-muted">Edit</a></td>
|
<td><a href={EditItemAction item.id} class="text-muted">Edit</a></td>
|
||||||
<td><a href={DeleteTaskAction task.id} class="js-delete text-muted">Delete</a></td>
|
<td><a href={DeleteItemAction item.id} class="js-delete text-muted">Delete</a></td>
|
||||||
</tr>
|
</tr>
|
||||||
|]
|
|]
|
||||||
|
|
|
@ -1,25 +1,26 @@
|
||||||
module Web.View.Tasks.New where
|
module Web.View.Items.New where
|
||||||
|
|
||||||
import Web.View.Prelude
|
import Web.View.Prelude
|
||||||
import Text.Blaze.Html.Renderer.Text
|
import Text.Blaze.Html.Renderer.Text
|
||||||
|
|
||||||
data NewView = NewView { task :: Include "tags" Task }
|
data NewView = NewView { item :: Include "tags" Item }
|
||||||
|
|
||||||
instance View NewView where
|
instance View NewView where
|
||||||
html NewView { .. } = [hsx|
|
html NewView { .. } = [hsx|
|
||||||
{breadcrumb}
|
{breadcrumb}
|
||||||
<h1>New Task</h1>
|
<h1>New Item</h1>
|
||||||
|
|
||||||
{renderForm task}
|
{renderForm item}
|
||||||
|]
|
|]
|
||||||
where
|
where
|
||||||
breadcrumb = renderBreadcrumb
|
breadcrumb = renderBreadcrumb
|
||||||
[ breadcrumbLink "Tasks" TasksAction
|
[ breadcrumbLink "Items" ItemsAction
|
||||||
, breadcrumbText "New Task"
|
, breadcrumbText "New Item"
|
||||||
]
|
]
|
||||||
|
|
||||||
renderForm :: Include "tags" Task -> Html
|
renderForm :: Include "tags" Item -> Html
|
||||||
renderForm task = formFor task [hsx|
|
renderForm item = formFor item [hsx|
|
||||||
|
{textField #wikidataId}
|
||||||
{textField #description}
|
{textField #description}
|
||||||
|
|
||||||
<fieldset>
|
<fieldset>
|
|
@ -0,0 +1,17 @@
|
||||||
|
module Web.View.Items.Show where
|
||||||
|
import Web.View.Prelude
|
||||||
|
|
||||||
|
data ShowView = ShowView { item :: Item }
|
||||||
|
|
||||||
|
instance View ShowView where
|
||||||
|
html ShowView { .. } = [hsx|
|
||||||
|
{breadcrumb}
|
||||||
|
<h1>Show Item</h1>
|
||||||
|
<p>{item}</p>
|
||||||
|
|
||||||
|
|]
|
||||||
|
where
|
||||||
|
breadcrumb = renderBreadcrumb
|
||||||
|
[ breadcrumbLink "Items" ItemsAction
|
||||||
|
, breadcrumbText "Show Item"
|
||||||
|
]
|
|
@ -1,17 +0,0 @@
|
||||||
module Web.View.Tasks.Edit where
|
|
||||||
import Web.View.Prelude
|
|
||||||
import Web.View.Tasks.New (renderForm)
|
|
||||||
|
|
||||||
data EditView = EditView { task :: Include "tags" Task }
|
|
||||||
|
|
||||||
instance View EditView where
|
|
||||||
html EditView { .. } = [hsx|
|
|
||||||
{breadcrumb}
|
|
||||||
<h1>Edit Task</h1>
|
|
||||||
{renderForm task}
|
|
||||||
|]
|
|
||||||
where
|
|
||||||
breadcrumb = renderBreadcrumb
|
|
||||||
[ breadcrumbLink "Tasks" TasksAction
|
|
||||||
, breadcrumbText "Edit Task"
|
|
||||||
]
|
|
|
@ -1,17 +0,0 @@
|
||||||
module Web.View.Tasks.Show where
|
|
||||||
import Web.View.Prelude
|
|
||||||
|
|
||||||
data ShowView = ShowView { task :: Task }
|
|
||||||
|
|
||||||
instance View ShowView where
|
|
||||||
html ShowView { .. } = [hsx|
|
|
||||||
{breadcrumb}
|
|
||||||
<h1>Show Task</h1>
|
|
||||||
<p>{task}</p>
|
|
||||||
|
|
||||||
|]
|
|
||||||
where
|
|
||||||
breadcrumb = renderBreadcrumb
|
|
||||||
[ breadcrumbLink "Tasks" TasksAction
|
|
||||||
, breadcrumbText "Show Task"
|
|
||||||
]
|
|
|
@ -30,9 +30,11 @@
|
||||||
wai
|
wai
|
||||||
text
|
text
|
||||||
hlint
|
hlint
|
||||||
|
http-conduit
|
||||||
|
aeson
|
||||||
];
|
];
|
||||||
};
|
};
|
||||||
};
|
};
|
||||||
|
|
||||||
};
|
};
|
||||||
}
|
}
|
||||||
|
|
File diff suppressed because one or more lines are too long
Loading…
Reference in New Issue