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.
|
||||
--
|
||||
|
||||
name: App
|
||||
name: CompareWare
|
||||
version: 0.1.0.0
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: AllRightsReserved
|
||||
license: GNU GPLv3
|
||||
license-file: LICENSE
|
||||
author: Developers
|
||||
maintainer: developers@example.com
|
||||
author: CompareWare Developers
|
||||
maintainer: hello@compareware.org
|
||||
-- copyright:
|
||||
-- category:
|
||||
build-type: Simple
|
||||
|
@ -25,10 +25,12 @@ executable App
|
|||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends:
|
||||
ihp,
|
||||
base,
|
||||
wai,
|
||||
text
|
||||
ihp
|
||||
, base
|
||||
, wai
|
||||
, text
|
||||
, http-conduit
|
||||
, aeson
|
||||
hs-source-dirs: .
|
||||
default-language: Haskell2010
|
||||
extensions:
|
||||
|
@ -68,4 +70,4 @@ executable App
|
|||
, FunctionalDependencies
|
||||
, PartialTypeSignatures
|
||||
, StandaloneDeriving
|
||||
, DerivingVia
|
||||
, DerivingVia
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
CREATE TABLE tasks (
|
||||
CREATE TABLE items (
|
||||
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
|
||||
description TEXT NOT NULL
|
||||
);
|
||||
CREATE TABLE tags (
|
||||
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY 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);
|
||||
ALTER TABLE tags ADD CONSTRAINT tags_ref_task_id FOREIGN KEY (task_id) REFERENCES tasks (id) ON DELETE NO ACTION;
|
||||
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 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.
|
||||
CREATE TABLE tasks (
|
||||
CREATE TABLE items (
|
||||
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 (
|
||||
id UUID DEFAULT uuid_generate_v4() PRIMARY KEY NOT NULL,
|
||||
item_id UUID 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);
|
||||
ALTER TABLE tags ADD CONSTRAINT tags_ref_task_id FOREIGN KEY (task_id) REFERENCES tasks (id) ON DELETE NO ACTION;
|
||||
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;
|
||||
|
|
14
README.md
14
README.md
|
@ -1,5 +1,8 @@
|
|||
# [CompareWare](https://compareware.org)
|
||||
|
||||
This application is still a prototype,
|
||||
with only a landing page publicly available thus far.
|
||||
|
||||
## Use-Cases
|
||||
- Authorised users can create `Items`: Working, no authorisations
|
||||
- `Items` can have `Tags`: Implemented
|
||||
|
@ -26,11 +29,9 @@ and normalizes the schema.
|
|||
|
||||
![CompareWare Overview Entity Relationship Diagram](compareware-erd.png)
|
||||
|
||||
Of course, every many-to-many relationship needs another table
|
||||
to be represented in a normalized well,
|
||||
which the diagram of the actual structure used in the code illustrates:
|
||||
|
||||
TODO
|
||||
For a fully normalized and implementable view,
|
||||
every many-to-many relationship needs another table
|
||||
which will be visible in a diagram generated from the [schema](./Application/Schema.sql).
|
||||
|
||||
## Developer Setup
|
||||
|
||||
|
@ -38,3 +39,6 @@ TODO
|
|||
direnv allow
|
||||
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)
|
||||
|
||||
-- Controller Imports
|
||||
import Web.Controller.Tasks
|
||||
import Web.Controller.Items
|
||||
import Web.Controller.Static
|
||||
|
||||
instance FrontController WebApplication where
|
||||
controllers =
|
||||
[ startPage TasksAction
|
||||
[ startPage ItemsAction
|
||||
-- Generator Marker
|
||||
, parseRoute @TasksController
|
||||
, parseRoute @ItemsController
|
||||
]
|
||||
|
||||
instance InitControllerContext WebApplication where
|
||||
|
|
|
@ -5,5 +5,5 @@ import Web.Types
|
|||
|
||||
-- Generator Marker
|
||||
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 TasksController
|
||||
= TasksAction
|
||||
| NewTaskAction
|
||||
| ShowTaskAction { taskId :: !(Id Task) }
|
||||
| CreateTaskAction
|
||||
| EditTaskAction { taskId :: !(Id Task) }
|
||||
| UpdateTaskAction { taskId :: !(Id Task) }
|
||||
| DeleteTaskAction { taskId :: !(Id Task) }
|
||||
data ItemsController
|
||||
= ItemsAction
|
||||
| NewItemAction
|
||||
| ShowItemAction { itemId :: !(Id Item) }
|
||||
| CreateItemAction
|
||||
| EditItemAction { itemId :: !(Id Item) }
|
||||
| UpdateItemAction { itemId :: !(Id Item) }
|
||||
| DeleteItemAction { itemId :: !(Id Item) }
|
||||
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
|
||||
|
||||
data IndexView = IndexView { tasks :: [Include "tags" Task] }
|
||||
data IndexView = IndexView { items :: [Include "tags" Item] }
|
||||
|
||||
instance View IndexView where
|
||||
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">
|
||||
<table class="table">
|
||||
<thead>
|
||||
<tr>
|
||||
<th>Task</th>
|
||||
<th>Item</th>
|
||||
<th></th>
|
||||
<th></th>
|
||||
<th></th>
|
||||
</tr>
|
||||
</thead>
|
||||
<tbody>{forEach tasks renderTask}</tbody>
|
||||
<tbody>{forEach items renderItem}</tbody>
|
||||
</table>
|
||||
|
||||
</div>
|
||||
|]
|
||||
where
|
||||
breadcrumb = renderBreadcrumb
|
||||
[ breadcrumbLink "Tasks" TasksAction
|
||||
[ breadcrumbLink "Items" ItemsAction
|
||||
]
|
||||
|
||||
renderTask :: Include "tags" Task -> Html
|
||||
renderTask task = [hsx|
|
||||
renderItem :: Include "tags" Item -> Html
|
||||
renderItem item = [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>
|
||||
<td>{item.description}</td>
|
||||
<td>{renderTags item.tags}</td>
|
||||
<td><a href={ShowItemAction item.id}>Show</a></td>
|
||||
<td><a href={EditItemAction item.id} class="text-muted">Edit</a></td>
|
||||
<td><a href={DeleteItemAction item.id} class="js-delete text-muted">Delete</a></td>
|
||||
</tr>
|
||||
|]
|
||||
|
|
@ -1,25 +1,26 @@
|
|||
module Web.View.Tasks.New where
|
||||
module Web.View.Items.New where
|
||||
|
||||
import Web.View.Prelude
|
||||
import Text.Blaze.Html.Renderer.Text
|
||||
|
||||
data NewView = NewView { task :: Include "tags" Task }
|
||||
data NewView = NewView { item :: Include "tags" Item }
|
||||
|
||||
instance View NewView where
|
||||
html NewView { .. } = [hsx|
|
||||
{breadcrumb}
|
||||
<h1>New Task</h1>
|
||||
<h1>New Item</h1>
|
||||
|
||||
{renderForm task}
|
||||
{renderForm item}
|
||||
|]
|
||||
where
|
||||
breadcrumb = renderBreadcrumb
|
||||
[ breadcrumbLink "Tasks" TasksAction
|
||||
, breadcrumbText "New Task"
|
||||
[ breadcrumbLink "Items" ItemsAction
|
||||
, breadcrumbText "New Item"
|
||||
]
|
||||
|
||||
renderForm :: Include "tags" Task -> Html
|
||||
renderForm task = formFor task [hsx|
|
||||
renderForm :: Include "tags" Item -> Html
|
||||
renderForm item = formFor item [hsx|
|
||||
{textField #wikidataId}
|
||||
{textField #description}
|
||||
|
||||
<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"
|
||||
]
|
File diff suppressed because one or more lines are too long
Loading…
Reference in New Issue