diff options
-rw-r--r-- | Handler/Common.hs | 43 | ||||
-rw-r--r-- | Handler/Common/Types.hs | 4 | ||||
-rw-r--r-- | Handler/InventoryListing.hs | 21 | ||||
-rw-r--r-- | Handler/Item.hs | 27 | ||||
-rw-r--r-- | Handler/List.hs | 44 | ||||
-rw-r--r-- | Handler/ReferenceItem.hs | 17 | ||||
-rw-r--r-- | Handler/ReferenceListing.hs | 21 | ||||
-rw-r--r-- | Handler/UpdateItem.hs | 23 | ||||
-rw-r--r-- | Model.hs | 90 | ||||
-rw-r--r-- | config/models | 10 | ||||
-rw-r--r-- | config/routes | 3 | ||||
-rw-r--r-- | templates/default-layout.cassius | 19 | ||||
-rw-r--r-- | templates/inventoryListing.hamlet | 4 | ||||
-rw-r--r-- | templates/referenceListing.hamlet | 4 |
14 files changed, 241 insertions, 89 deletions
diff --git a/Handler/Common.hs b/Handler/Common.hs index 2416d15..1cf63de 100644 --- a/Handler/Common.hs +++ b/Handler/Common.hs | |||
@@ -18,6 +18,9 @@ import Data.Unique | |||
18 | 18 | ||
19 | import qualified Data.Text as Text (pack) | 19 | import qualified Data.Text as Text (pack) |
20 | 20 | ||
21 | import Data.Set (Set) | ||
22 | import qualified Data.Set as Set | ||
23 | |||
21 | import Control.Lens | 24 | import Control.Lens |
22 | 25 | ||
23 | import Handler.Common.Types | 26 | import Handler.Common.Types |
@@ -26,11 +29,14 @@ dayFormat :: Day -> String | |||
26 | dayFormat = formatTime defaultTimeLocale "%e. %b %y" | 29 | dayFormat = formatTime defaultTimeLocale "%e. %b %y" |
27 | 30 | ||
28 | itemForm :: Maybe Item -- ^ Update existing item or insert new? | 31 | itemForm :: Maybe Item -- ^ Update existing item or insert new? |
29 | -> Html -> MForm Handler (FormResult Item, Widget) | 32 | -> Html -> MForm Handler (FormResult (WithType Item), Widget) |
30 | itemForm proto identView = do | 33 | itemForm proto identView = do |
31 | today <- utctDay <$> liftIO getCurrentTime | 34 | today <- utctDay <$> liftIO getCurrentTime |
35 | |||
36 | t <- lift . runDB $ maybe (return Nothing) (fmap (Just . kindType) . getType) proto | ||
32 | 37 | ||
33 | (kindRes, kindWidget) <- kindField $ itemKind <$> proto | 38 | (kindRes, kindWidget) <- kindField $ itemKind <$> proto |
39 | (typeRes, typeWidget) <- typeField $ t | ||
34 | (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown" | 40 | (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown" |
35 | (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never" | 41 | (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never" |
36 | (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never" | 42 | (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never" |
@@ -40,13 +46,15 @@ itemForm proto identView = do | |||
40 | itemBought <- boughtRes | 46 | itemBought <- boughtRes |
41 | itemExpires <- expiresRes | 47 | itemExpires <- expiresRes |
42 | itemOpened <- openedRes | 48 | itemOpened <- openedRes |
43 | return Item{ itemNormKind = normalizeKind itemKind, ..} | 49 | t <- typeRes |
50 | return $ Item{ itemNormKind = normalizeKind itemKind, ..} `WithType` t | ||
44 | 51 | ||
45 | return . (itemRes, ) $ | 52 | return . (itemRes, ) $ |
46 | [whamlet| | 53 | [whamlet| |
47 | $newline never | 54 | $newline never |
48 | #{identView} | 55 | #{identView} |
49 | <div .td>^{kindWidget} | 56 | <div .td>^{kindWidget} |
57 | <div .td>^{typeWidget} | ||
50 | <div .td>^{boughtWidget} | 58 | <div .td>^{boughtWidget} |
51 | <div .td>^{expiresWidget} | 59 | <div .td>^{expiresWidget} |
52 | <div .td>^{openedWidget} | 60 | <div .td>^{openedWidget} |
@@ -81,19 +89,24 @@ inventoryListing :: InventoryState -> Widget | |||
81 | inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing") | 89 | inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing") |
82 | 90 | ||
83 | referenceForm :: Maybe Reference -- ^ Update existing item or insert new? | 91 | referenceForm :: Maybe Reference -- ^ Update existing item or insert new? |
84 | -> Html -> MForm Handler (FormResult Reference, Widget) | 92 | -> Html -> MForm Handler (FormResult (WithType Reference), Widget) |
85 | referenceForm proto identView = do | 93 | referenceForm proto identView = do |
94 | t <- lift . runDB $ maybe (return Nothing) (fmap (Just . kindType) . getType) proto | ||
95 | |||
86 | (kindRes, kindWidget) <- kindField $ referenceKind <$> proto | 96 | (kindRes, kindWidget) <- kindField $ referenceKind <$> proto |
97 | (typeRes, typeWidget) <- typeField $ t | ||
87 | 98 | ||
88 | let referenceRes = do | 99 | let referenceRes = do |
89 | referenceKind <- kindRes | 100 | referenceKind <- kindRes |
90 | return Reference{ referenceNormKind = normalizeKind referenceKind, .. } | 101 | t <- typeRes |
102 | return $ Reference{ referenceNormKind = normalizeKind referenceKind, .. } `WithType` t | ||
91 | 103 | ||
92 | return . (referenceRes, ) $ | 104 | return . (referenceRes, ) $ |
93 | [whamlet| | 105 | [whamlet| |
94 | $newline never | 106 | $newline never |
95 | #{identView} | 107 | #{identView} |
96 | <div .td>^{kindWidget} | 108 | <div .td>^{kindWidget} |
109 | <div .td>^{typeWidget} | ||
97 | |] | 110 | |] |
98 | 111 | ||
99 | referenceListing :: ReferenceState -> Widget | 112 | referenceListing :: ReferenceState -> Widget |
@@ -121,6 +134,28 @@ kindField proto = do | |||
121 | <option value=#{opt}> | 134 | <option value=#{opt}> |
122 | |] | 135 | |] |
123 | 136 | ||
137 | typeField :: Maybe Text -> MForm Handler (FormResult Text, Widget) | ||
138 | typeField proto = do | ||
139 | optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique | ||
140 | |||
141 | let | ||
142 | attrs = [ ("list", optionId) | ||
143 | , ("autocomplete", "off") | ||
144 | ] | ||
145 | |||
146 | (typeRes, typeView) <- mreq textField ("" { fsAttrs = attrs }) proto | ||
147 | |||
148 | (Set.fromList . map (kindType . entityVal) -> options) <- lift . runDB $ selectList [] [] | ||
149 | |||
150 | return . (typeRes, ) $ | ||
151 | [whamlet| | ||
152 | $newline never | ||
153 | ^{fvInput typeView} | ||
154 | <datalist ##{optionId}> | ||
155 | $forall opt <- Set.toList options | ||
156 | <option value=#{opt}> | ||
157 | |] | ||
158 | |||
124 | kinds :: Handler [Text] | 159 | kinds :: Handler [Text] |
125 | kinds = do | 160 | kinds = do |
126 | stock <- runDB $ selectList [] [] | 161 | stock <- runDB $ selectList [] [] |
diff --git a/Handler/Common/Types.hs b/Handler/Common/Types.hs index 08653af..9150f16 100644 --- a/Handler/Common/Types.hs +++ b/Handler/Common/Types.hs | |||
@@ -7,12 +7,12 @@ import Import | |||
7 | import Control.Lens | 7 | import Control.Lens |
8 | 8 | ||
9 | data InventoryState = InventoryState | 9 | data InventoryState = InventoryState |
10 | { stock :: [Entity Item] | 10 | { stock :: [WithType (Entity Item)] |
11 | , invFormState :: Maybe (FormState ItemId) | 11 | , invFormState :: Maybe (FormState ItemId) |
12 | } | 12 | } |
13 | 13 | ||
14 | data ReferenceState = ReferenceState | 14 | data ReferenceState = ReferenceState |
15 | { reference :: [Entity Reference] | 15 | { reference :: [WithType (Entity Reference)] |
16 | , refFormState :: Maybe (FormState ReferenceId) | 16 | , refFormState :: Maybe (FormState ReferenceId) |
17 | } | 17 | } |
18 | 18 | ||
diff --git a/Handler/InventoryListing.hs b/Handler/InventoryListing.hs index 12f36ba..6d4d8fa 100644 --- a/Handler/InventoryListing.hs +++ b/Handler/InventoryListing.hs | |||
@@ -8,19 +8,26 @@ getInventoryListingR = postInventoryListingR | |||
8 | postInventoryListingR = do | 8 | postInventoryListingR = do |
9 | ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ itemForm Nothing | 9 | ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ itemForm Nothing |
10 | 10 | ||
11 | mapM_ (addMessage "formError" . toHtml) =<< case insertResult of | 11 | case insertResult of |
12 | FormSuccess newItem -> [] <$ runDB (insert newItem) | 12 | FormSuccess (Item{..} `WithType` t) -> runDB $ do |
13 | FormFailure errors -> return errors | 13 | upsertBy (UniqueKind itemNormKind) (Kind itemNormKind t) [ KindType =. t ] |
14 | _ -> return [] | 14 | insert Item{..} |
15 | return () | ||
16 | FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors | ||
17 | _ -> return () | ||
15 | 18 | ||
16 | (sortOn entityVal -> stock) <- runDB $ selectList [] [] | 19 | (sortOn (entityVal . typedVal) -> stock) <- runDB $ mapM withType =<< selectList [] [] |
17 | 20 | ||
18 | selectRep $ do | 21 | selectRep $ do |
19 | provideJson (stock :: [Entity Item]) | 22 | provideJson (stock :: [WithType (Entity Item)]) |
20 | provideRep . defaultLayout $ inventoryListing InventoryState | 23 | provideRep . defaultLayout $ inventoryListing InventoryState |
21 | { invFormState = Just InsertForm{..} | 24 | { invFormState = Just InsertForm{..} |
22 | , .. | 25 | , .. |
23 | } | 26 | } |
24 | 27 | ||
25 | putInventoryListingR :: Handler Value | 28 | putInventoryListingR :: Handler Value |
26 | putInventoryListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Item) | 29 | putInventoryListingR = do |
30 | (Item{..} `WithType` t) <- requireCheckJsonBody | ||
31 | returnJson <=< runDB $ do | ||
32 | upsertBy (UniqueKind itemNormKind) (Kind itemNormKind t) [ KindType =. t ] | ||
33 | withType =<< insertEntity Item{..} | ||
diff --git a/Handler/Item.hs b/Handler/Item.hs index 0f48261..abb1b12 100644 --- a/Handler/Item.hs +++ b/Handler/Item.hs | |||
@@ -4,26 +4,31 @@ import Import | |||
4 | 4 | ||
5 | getItemR :: ItemId -> Handler TypedContent | 5 | getItemR :: ItemId -> Handler TypedContent |
6 | getItemR itemId = do | 6 | getItemR itemId = do |
7 | entity <- runDB $ Entity itemId <$> get404 itemId | 7 | entity <- runDB $ withType =<< Entity itemId <$> get404 itemId |
8 | selectRep $ do | 8 | selectRep $ do |
9 | provideJson entity | 9 | provideJson entity |
10 | provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html) | 10 | provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html) |
11 | 11 | ||
12 | putItemR :: ItemId -> Handler Value | 12 | putItemR :: ItemId -> Handler Value |
13 | putItemR itemId = do | 13 | putItemR itemId = do |
14 | Item{..} <- requireCheckJsonBody | 14 | (Item{..} `WithType` t) <- requireCheckJsonBody |
15 | returnJson . Entity itemId =<< runDB | 15 | returnJson <=< runDB $ do |
16 | (updateGet itemId [ ItemKind =. itemKind | 16 | entity <- Entity itemId <$> (updateGet itemId [ ItemKind =. itemKind |
17 | , ItemNormKind =. itemNormKind | 17 | , ItemNormKind =. itemNormKind |
18 | , ItemBought =. itemBought | 18 | , ItemBought =. itemBought |
19 | , ItemExpires =. itemExpires | 19 | , ItemExpires =. itemExpires |
20 | , ItemOpened =. itemOpened | 20 | , ItemOpened =. itemOpened |
21 | ]) | 21 | ]) |
22 | update (itemFkType $ entityVal entity) [ KindType =. t ] | ||
23 | withType entity | ||
22 | 24 | ||
23 | patchItemR :: ItemId -> Handler Value | 25 | patchItemR :: ItemId -> Handler Value |
24 | patchItemR itemId = do | 26 | patchItemR itemId = do |
25 | diffs <- (requireCheckJsonBody :: Handler ItemDiffs) | 27 | (itemUpdates, typeUpdates) <- toUpdate <$> (requireCheckJsonBody :: Handler ItemDiffs) |
26 | returnJson . Entity itemId =<< runDB (updateGet itemId $ toUpdate diffs) | 28 | returnJson <=< runDB $ do |
29 | entity <- Entity itemId <$> updateGet itemId itemUpdates | ||
30 | update (itemFkType $ entityVal entity) typeUpdates | ||
31 | withType entity | ||
27 | 32 | ||
28 | deleteItemR :: ItemId -> Handler () | 33 | deleteItemR :: ItemId -> Handler () |
29 | deleteItemR = runDB . delete | 34 | deleteItemR = runDB . delete |
diff --git a/Handler/List.hs b/Handler/List.hs index cfd3f7c..70f323a 100644 --- a/Handler/List.hs +++ b/Handler/List.hs | |||
@@ -18,17 +18,18 @@ import Database.Persist.Sql (Single(..), rawSql) | |||
18 | 18 | ||
19 | import Thermoprint.Client | 19 | import Thermoprint.Client |
20 | 20 | ||
21 | list :: Handler (Set Text) | 21 | list :: Handler (Set (WithType Text)) |
22 | list = do | 22 | list = do |
23 | (map unSingle -> kinds) <- runDB $ rawSql "select reference.kind from reference where not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind)) " [] | 23 | (map (uncurry WithType . bimap unSingle unSingle) -> kinds) <- runDB $ rawSql "select reference.kind, kind.type from reference,kind where (not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind))) and (reference.norm_kind = kind.norm_kind)" [] |
24 | return $ Set.fromList kinds | 24 | return $ Set.fromList kinds |
25 | 25 | ||
26 | mkPrintout :: Set Text -> Printout | 26 | mkPrintout :: Set (WithType Text) -> Printout |
27 | mkPrintout list = Printout | 27 | mkPrintout list = Printout ps |
28 | [ Paragraph | 28 | where |
29 | [Cooked . either id Line . text . Lazy.Text.fromStrict . Text.unlines . map (" - " <>) $ Set.toAscList list | 29 | ps = Map.foldMapWithKey (fmap (pure . Paragraph . pure . Cooked) . toLines) $ group list |
30 | ] | 30 | group = Map.fromListWith (<>) . fmap (\(kind `WithType` t) -> (t, Set.singleton kind)) . Set.toAscList |
31 | ] | 31 | toLines t (Set.toAscList -> kinds) = either id Line . text . Lazy.Text.fromStrict . Text.unlines $ |
32 | pure t ++ map (" - " <>) kinds | ||
32 | 33 | ||
33 | getListR, postListR :: Handler TypedContent | 34 | getListR, postListR :: Handler TypedContent |
34 | getListR = postListR | 35 | getListR = postListR |
@@ -54,18 +55,21 @@ postListR = do | |||
54 | _ -> return () | 55 | _ -> return () |
55 | 56 | ||
56 | selectRep $ do | 57 | selectRep $ do |
57 | provideJson list | 58 | provideJson $ typeToJSON "item" <$> Set.toAscList list |
58 | provideRep . defaultLayout $ | 59 | provideRep . defaultLayout $ |
59 | [whamlet| | 60 | [whamlet| |
60 | <div .table .main> | 61 | <table .main> |
61 | <div .tr .sepBelow> | 62 | <tr .sepBelow> |
62 | <div .th>Item | 63 | <th>Item |
63 | $forall item <- Set.toAscList list | 64 | <th>Type |
64 | <div .tr .color> | 65 | $forall WithType item itemType <- Set.toAscList list |
65 | <div .kind>#{item} | 66 | <tr .color> |
66 | <form .tr .sepAbove method=post action=@{ListR} enctype=#{printEnc}> | 67 | <td .kind>#{item} |
67 | <div .td> | 68 | <td .type>#{itemType} |
68 | ^{printView} | 69 | <tr .sepAbove> |
69 | <button type=submit :Set.null list:disabled> | 70 | <td colspan=2> |
70 | 71 | <form method=post action=@{ListR} enctype=#{printEnc}> | |
72 | ^{printView} | ||
73 | <button type=submit :Set.null list:disabled> | ||
74 | |||
71 | |] | 75 | |] |
diff --git a/Handler/ReferenceItem.hs b/Handler/ReferenceItem.hs index 738c9f3..44cd0a8 100644 --- a/Handler/ReferenceItem.hs +++ b/Handler/ReferenceItem.hs | |||
@@ -4,7 +4,7 @@ import Import | |||
4 | 4 | ||
5 | getReferenceItemR :: ReferenceId -> Handler TypedContent | 5 | getReferenceItemR :: ReferenceId -> Handler TypedContent |
6 | getReferenceItemR referenceId = do | 6 | getReferenceItemR referenceId = do |
7 | entity <- runDB $ Entity referenceId <$> get404 referenceId | 7 | entity <- runDB $ withType =<< Entity referenceId <$> get404 referenceId |
8 | selectRep $ do | 8 | selectRep $ do |
9 | provideJson entity | 9 | provideJson entity |
10 | provideRep (redirect $ ReferenceListingR :#: referenceId :: Handler Html) | 10 | provideRep (redirect $ ReferenceListingR :#: referenceId :: Handler Html) |
@@ -12,14 +12,13 @@ getReferenceItemR referenceId = do | |||
12 | 12 | ||
13 | putReferenceItemR :: ReferenceId -> Handler Value | 13 | putReferenceItemR :: ReferenceId -> Handler Value |
14 | putReferenceItemR referenceId = do | 14 | putReferenceItemR referenceId = do |
15 | Reference{..} <- requireCheckJsonBody | 15 | (Reference{..} `WithType` t) <- requireCheckJsonBody |
16 | returnJson . Entity referenceId =<< runDB | 16 | returnJson <=< runDB $ do |
17 | (updateGet referenceId [ ReferenceKind =. referenceKind | 17 | entity <- Entity referenceId <$> updateGet referenceId [ ReferenceKind =. referenceKind |
18 | , ReferenceNormKind =. referenceNormKind | 18 | , ReferenceNormKind =. referenceNormKind |
19 | ]) | 19 | ] |
20 | 20 | update (referenceFkType $ entityVal entity) [ KindType =. t ] | |
21 | patchReferenceItemR :: ReferenceId -> Handler Value | 21 | withType entity |
22 | patchReferenceItemR = putReferenceItemR -- Just one field | ||
23 | 22 | ||
24 | deleteReferenceItemR :: ReferenceId -> Handler () | 23 | deleteReferenceItemR :: ReferenceId -> Handler () |
25 | deleteReferenceItemR = runDB . delete | 24 | deleteReferenceItemR = runDB . delete |
diff --git a/Handler/ReferenceListing.hs b/Handler/ReferenceListing.hs index 0f777ee..0b89a20 100644 --- a/Handler/ReferenceListing.hs +++ b/Handler/ReferenceListing.hs | |||
@@ -9,19 +9,26 @@ getReferenceListingR = postReferenceListingR | |||
9 | postReferenceListingR = do | 9 | postReferenceListingR = do |
10 | ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ referenceForm Nothing | 10 | ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ referenceForm Nothing |
11 | 11 | ||
12 | mapM_ (addMessage "formError" . toHtml) =<< case insertResult of | 12 | case insertResult of |
13 | FormSuccess newReference -> [] <$ runDB (insert newReference) | 13 | FormSuccess (Reference{..} `WithType` t) -> runDB $ do |
14 | FormFailure errors -> return errors | 14 | upsertBy (UniqueKind referenceNormKind) (Kind referenceNormKind t) [ KindType =. t ] |
15 | _ -> return [] | 15 | insert Reference{..} |
16 | return () | ||
17 | FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors | ||
18 | _ -> return () | ||
16 | 19 | ||
17 | reference <- runDB $ selectList [] [Asc ReferenceKind] | 20 | reference <- runDB $ mapM withType =<< selectList [] [Asc ReferenceKind] |
18 | 21 | ||
19 | selectRep $ do | 22 | selectRep $ do |
20 | provideJson (reference :: [Entity Reference]) | 23 | provideJson (reference :: [WithType (Entity Reference)]) |
21 | provideRep . defaultLayout $ referenceListing ReferenceState | 24 | provideRep . defaultLayout $ referenceListing ReferenceState |
22 | { refFormState = Just InsertForm{..} | 25 | { refFormState = Just InsertForm{..} |
23 | , .. | 26 | , .. |
24 | } | 27 | } |
25 | 28 | ||
26 | putReferenceListingR :: Handler Value | 29 | putReferenceListingR :: Handler Value |
27 | putReferenceListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Reference) | 30 | putReferenceListingR = do |
31 | (Reference{..} `WithType` referenceType) <- requireCheckJsonBody | ||
32 | returnJson <=< runDB $ do | ||
33 | upsertBy (UniqueKind referenceNormKind) (Kind referenceNormKind referenceType) [ KindType =. referenceType ] | ||
34 | withType =<< insertEntity Reference{..} | ||
diff --git a/Handler/UpdateItem.hs b/Handler/UpdateItem.hs index a4a29c2..befbe99 100644 --- a/Handler/UpdateItem.hs +++ b/Handler/UpdateItem.hs | |||
@@ -11,21 +11,24 @@ postUpdateItemR fsUpdateId = do | |||
11 | 11 | ||
12 | ((updateResult, fsUpdateForm), fsUpdateEncoding) <- runFormPost . itemForm . Just $ entityVal entity | 12 | ((updateResult, fsUpdateForm), fsUpdateEncoding) <- runFormPost . itemForm . Just $ entityVal entity |
13 | 13 | ||
14 | mapM_ (addMessage "formError" . toHtml) =<< case updateResult of | 14 | case updateResult of |
15 | FormSuccess Item{..} -> [] <$ runDB (update fsUpdateId [ ItemKind =. itemKind | 15 | FormSuccess (Item{..} `WithType` t) -> runDB $ do |
16 | , ItemNormKind =. normalizeKind itemKind | 16 | upsertBy (UniqueKind itemNormKind) (Kind itemNormKind t) [ KindType =. t ] |
17 | , ItemBought =. itemBought | 17 | update fsUpdateId [ ItemKind =. itemKind |
18 | , ItemExpires =. itemExpires | 18 | , ItemNormKind =. itemNormKind |
19 | , ItemOpened =. itemOpened | 19 | , ItemBought =. itemBought |
20 | ]) | 20 | , ItemExpires =. itemExpires |
21 | FormFailure errors -> return errors | 21 | , ItemOpened =. itemOpened |
22 | _ -> return [] | 22 | ] |
23 | return () | ||
24 | FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors | ||
25 | _ -> return () | ||
23 | 26 | ||
24 | selectRep $ do | 27 | selectRep $ do |
25 | provideRep $ case updateResult of | 28 | provideRep $ case updateResult of |
26 | FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateId :: Handler Html | 29 | FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateId :: Handler Html |
27 | _ -> do | 30 | _ -> do |
28 | (sortOn entityVal -> stock) <- runDB $ selectList [] [] | 31 | (sortOn (entityVal . typedVal) -> stock) <- runDB $ mapM withType =<< selectList [] [] |
29 | defaultLayout $ inventoryListing InventoryState | 32 | defaultLayout $ inventoryListing InventoryState |
30 | { invFormState = Just UpdateForm{..} | 33 | { invFormState = Just UpdateForm{..} |
31 | , .. | 34 | , .. |
@@ -10,7 +10,10 @@ import Control.Monad.Writer | |||
10 | import Data.Text (Text) | 10 | import Data.Text (Text) |
11 | import qualified Data.Text as Text | 11 | import qualified Data.Text as Text |
12 | 12 | ||
13 | import qualified Data.HashMap.Lazy as HashMap | ||
14 | |||
13 | import Data.Aeson | 15 | import Data.Aeson |
16 | import Data.Aeson.Types (Parser, Value(..)) | ||
14 | 17 | ||
15 | -- You can define all of your database entities in the entities file. | 18 | -- You can define all of your database entities in the entities file. |
16 | -- You can find more information on persistent and how to declare entities | 19 | -- You can find more information on persistent and how to declare entities |
@@ -19,6 +22,28 @@ import Data.Aeson | |||
19 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] | 22 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] |
20 | $(persistFileWith lowerCaseSettings "config/models") | 23 | $(persistFileWith lowerCaseSettings "config/models") |
21 | 24 | ||
25 | class HasType a where | ||
26 | getType :: ( BaseBackend backend ~ SqlBackend | ||
27 | , MonadIO m | ||
28 | , PersistStoreRead backend | ||
29 | ) => a -> ReaderT backend m Kind | ||
30 | |||
31 | instance HasType Item where | ||
32 | getType = belongsToJust itemFkType | ||
33 | |||
34 | instance HasType Reference where | ||
35 | getType = belongsToJust referenceFkType | ||
36 | |||
37 | instance HasType a => HasType (Entity a) where | ||
38 | getType Entity{..} = getType entityVal | ||
39 | |||
40 | withType :: ( BaseBackend backend ~ SqlBackend | ||
41 | , MonadIO m | ||
42 | , PersistStoreRead backend | ||
43 | , HasType a | ||
44 | ) => a -> ReaderT backend m (WithType a) | ||
45 | withType val = (val `WithType`) . kindType <$> getType val | ||
46 | |||
22 | instance Ord Item where | 47 | instance Ord Item where |
23 | x `compare` y = mconcat | 48 | x `compare` y = mconcat |
24 | [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y) | 49 | [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y) |
@@ -71,6 +96,7 @@ normalizeKind :: Text -> Text | |||
71 | normalizeKind = Text.strip . Text.toCaseFold | 96 | normalizeKind = Text.strip . Text.toCaseFold |
72 | 97 | ||
73 | data ItemDiff = DiffKind Text | 98 | data ItemDiff = DiffKind Text |
99 | | DiffType Text | ||
74 | | DiffBought (Maybe Day) | 100 | | DiffBought (Maybe Day) |
75 | | DiffExpires (Maybe Day) | 101 | | DiffExpires (Maybe Day) |
76 | | DiffOpened (Maybe Day) | 102 | | DiffOpened (Maybe Day) |
@@ -80,17 +106,63 @@ newtype ItemDiffs = ItemDiffs [ItemDiff] | |||
80 | instance FromJSON ItemDiffs where | 106 | instance FromJSON ItemDiffs where |
81 | parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do | 107 | parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do |
82 | tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind") | 108 | tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind") |
109 | tell =<< maybe [] (pure . DiffType) <$> lift (obj .:? "type") | ||
83 | tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought") | 110 | tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought") |
84 | tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires") | 111 | tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires") |
85 | tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened") | 112 | tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened") |
86 | 113 | ||
87 | toUpdate :: ItemDiffs -> [Update Item] | 114 | toUpdate :: ItemDiffs -> ([Update Item], [Update Kind]) |
88 | toUpdate (ItemDiffs ds) = do | 115 | toUpdate (ItemDiffs ds) = mconcat $ do |
89 | x <- ds | 116 | x <- ds |
90 | case x of | 117 | return $ case x of |
91 | DiffKind t -> [ ItemKind =. t | 118 | DiffKind t -> (, []) [ ItemKind =. t |
92 | , ItemNormKind =. normalizeKind t | 119 | , ItemNormKind =. normalizeKind t |
93 | ] | 120 | ] |
94 | DiffBought d -> [ ItemBought =. d ] | 121 | DiffType t -> ([], ) [ KindType =. t ] |
95 | DiffExpires d -> [ ItemExpires =. d ] | 122 | DiffBought d -> (, []) [ ItemBought =. d ] |
96 | DiffOpened d -> [ ItemOpened =. d ] | 123 | DiffExpires d -> (, []) [ ItemExpires =. d ] |
124 | DiffOpened d -> (, []) [ ItemOpened =. d ] | ||
125 | |||
126 | data WithType a = WithType { typedVal :: a, valType :: Text } | ||
127 | deriving (Eq, Ord) | ||
128 | |||
129 | typeToJSON :: ToJSON a | ||
130 | => Text -- ^ Key for value, if needed | ||
131 | -> WithType a -> Value | ||
132 | typeToJSON valKey (record `WithType` t) = Object $ HashMap.insert "type" (toJSON t) o | ||
133 | where | ||
134 | o | ||
135 | | Object o' <- toJSON record = o' | ||
136 | | otherwise = HashMap.singleton valKey $ toJSON record | ||
137 | |||
138 | typeFromJSON :: FromJSON a | ||
139 | => Maybe Text -- ^ Key for value, if needed | ||
140 | -> Value -> Parser (WithType a) | ||
141 | typeFromJSON valKey = withObject "value with type" $ \obj -> do | ||
142 | t <- obj .: "type" | ||
143 | value <- case valKey of | ||
144 | Just key -> parseJSON =<< obj .: key | ||
145 | Nothing -> parseJSON $ Object obj | ||
146 | return $ value `WithType` t | ||
147 | |||
148 | instance ToJSON (WithType Item) where | ||
149 | toJSON = typeToJSON $ error "Item is not serializing correctly" | ||
150 | |||
151 | instance ToJSON (WithType (Entity Item)) where | ||
152 | toJSON = typeToJSON $ error "Entity Item is not serializing correctly" | ||
153 | |||
154 | instance ToJSON (WithType Reference) where | ||
155 | toJSON = typeToJSON "kind" | ||
156 | |||
157 | instance ToJSON (WithType (Entity Reference)) where | ||
158 | toJSON ((Entity eId ref) `WithType` t) = object | ||
159 | [ "id" .= eId | ||
160 | , "type" .= t | ||
161 | , "kind" .= referenceKind ref | ||
162 | ] | ||
163 | |||
164 | instance FromJSON (WithType Item) where | ||
165 | parseJSON = typeFromJSON Nothing | ||
166 | |||
167 | instance FromJSON (WithType Reference) where | ||
168 | parseJSON = typeFromJSON $ Just "kind" | ||
diff --git a/config/models b/config/models index aa335df..16b4ce0 100644 --- a/config/models +++ b/config/models | |||
@@ -4,9 +4,17 @@ Item | |||
4 | bought Day Maybe | 4 | bought Day Maybe |
5 | expires Day Maybe | 5 | expires Day Maybe |
6 | opened Day Maybe | 6 | opened Day Maybe |
7 | Foreign Kind fkType normKind | ||
7 | deriving Show Eq | 8 | deriving Show Eq |
8 | Reference | 9 | Reference |
9 | normKind Text | 10 | normKind Text |
10 | kind Text | 11 | kind Text |
12 | UniqueRefKind normKind | ||
13 | Foreign Kind fkType normKind | ||
14 | deriving Show Eq Ord | ||
15 | Kind | ||
16 | normKind Text | ||
17 | type Text | ||
18 | Primary normKind | ||
11 | UniqueKind normKind | 19 | UniqueKind normKind |
12 | deriving Show Eq Ord \ No newline at end of file | 20 | deriving Show Eq \ No newline at end of file |
diff --git a/config/routes b/config/routes index 08babf4..6ed3204 100644 --- a/config/routes +++ b/config/routes | |||
@@ -7,7 +7,8 @@ | |||
7 | /inv/#ItemId ItemR GET PUT PATCH DELETE | 7 | /inv/#ItemId ItemR GET PUT PATCH DELETE |
8 | 8 | ||
9 | /ref ReferenceListingR GET POST PUT | 9 | /ref ReferenceListingR GET POST PUT |
10 | /ref/#ReferenceId ReferenceItemR GET PUT PATCH DELETE | 10 | /ref/#ReferenceId ReferenceItemR GET PUT DELETE |
11 | /ref/#ReferenceId/delete DeleteRefItemR POST | 11 | /ref/#ReferenceId/delete DeleteRefItemR POST |
12 | |||
12 | /kinds KindsR GET | 13 | /kinds KindsR GET |
13 | /list ListR GET POST | 14 | /list ListR GET POST |
diff --git a/templates/default-layout.cassius b/templates/default-layout.cassius index c1ccf72..bd76a01 100644 --- a/templates/default-layout.cassius +++ b/templates/default-layout.cassius | |||
@@ -1,20 +1,20 @@ | |||
1 | .main | 1 | .main |
2 | min-width: 20em | 2 | min-width: 20em |
3 | .table | 3 | .table, table |
4 | display: table | 4 | display: table |
5 | border-collapse: collapse | 5 | border-collapse: collapse |
6 | .table div | 6 | .table div, table td |
7 | vertical-align: middle | 7 | vertical-align: middle |
8 | .td | 8 | .td, td |
9 | display: table-cell | 9 | display: table-cell |
10 | text-align: center | 10 | text-align: center |
11 | padding: 0.25em | 11 | padding: 0.25em |
12 | .tr | 12 | .tr, tr |
13 | display: table-row | 13 | display: table-row |
14 | .tc | 14 | .tc |
15 | display: table-caption | 15 | display: table-caption |
16 | padding: 0.25em | 16 | padding: 0.25em |
17 | .th | 17 | .th, th |
18 | display: table-cell | 18 | display: table-cell |
19 | font-variant: small-caps | 19 | font-variant: small-caps |
20 | font-weight: bold | 20 | font-weight: bold |
@@ -26,8 +26,15 @@ | |||
26 | padding: 0.25em | 26 | padding: 0.25em |
27 | .kind:only-child | 27 | .kind:only-child |
28 | text-align: center | 28 | text-align: center |
29 | .type | ||
30 | display: table-cell | ||
31 | text-align: center | ||
32 | padding: 0.25em | ||
33 | color: #aaa | ||
29 | .table .table .td, .table .table .tc, .table .table .th, .table .table .kind | 34 | .table .table .td, .table .table .tc, .table .table .th, .table .table .kind |
30 | padding: 0 | 35 | padding: 0 |
36 | table table td, table table th | ||
37 | padding: 0 | ||
31 | #messages | 38 | #messages |
32 | list-style-type: none | 39 | list-style-type: none |
33 | margin: 1em auto 1em 0 | 40 | margin: 1em auto 1em 0 |
@@ -55,7 +62,7 @@ button | |||
55 | background-color: #f0f0f0 | 62 | background-color: #f0f0f0 |
56 | .color:nth-child(odd) | 63 | .color:nth-child(odd) |
57 | background-color: #fff | 64 | background-color: #fff |
58 | body > div | 65 | body > div, body > table |
59 | margin: 0 auto | 66 | margin: 0 auto |
60 | .table > h1 | 67 | .table > h1 |
61 | display: table-caption | 68 | display: table-caption |
diff --git a/templates/inventoryListing.hamlet b/templates/inventoryListing.hamlet index 775176d..3be43db 100644 --- a/templates/inventoryListing.hamlet +++ b/templates/inventoryListing.hamlet | |||
@@ -1,6 +1,7 @@ | |||
1 | <div .table> | 1 | <div .table> |
2 | <div .tr .sepBelow> | 2 | <div .tr .sepBelow> |
3 | <div .th>Item | 3 | <div .th>Item |
4 | <div .th>Type | ||
4 | <div .th>Bought | 5 | <div .th>Bought |
5 | <div .th>Expires | 6 | <div .th>Expires |
6 | <div .th>Opened | 7 | <div .th>Opened |
@@ -12,7 +13,7 @@ | |||
12 | <div .td> | 13 | <div .td> |
13 | <button type=submit> | 14 | <button type=submit> |
14 | Insert | 15 | Insert |
15 | $forall Entity itemId Item{..} <- stock | 16 | $forall WithType (Entity itemId Item{..}) itemType <- stock |
16 | $if Just itemId == (preview updateId =<< formState) | 17 | $if Just itemId == (preview updateId =<< formState) |
17 | $with Just UpdateForm{..} <- formState | 18 | $with Just UpdateForm{..} <- formState |
18 | <form .tr .color action=@{UpdateItemR fsUpdateId}##{toPathPiece fsUpdateId} method=post enctype=#{fsUpdateEncoding} ##{toPathPiece fsUpdateId}> | 19 | <form .tr .color action=@{UpdateItemR fsUpdateId}##{toPathPiece fsUpdateId} method=post enctype=#{fsUpdateEncoding} ##{toPathPiece fsUpdateId}> |
@@ -23,6 +24,7 @@ | |||
23 | $else | 24 | $else |
24 | <div .tr .color ##{toPathPiece itemId}> | 25 | <div .tr .color ##{toPathPiece itemId}> |
25 | <div .kind>#{itemKind} | 26 | <div .kind>#{itemKind} |
27 | <div .type>#{itemType} | ||
26 | <div .td .day> | 28 | <div .td .day> |
27 | $maybe bought <- itemBought | 29 | $maybe bought <- itemBought |
28 | #{dayFormat bought} | 30 | #{dayFormat bought} |
diff --git a/templates/referenceListing.hamlet b/templates/referenceListing.hamlet index a76e603..414a3ec 100644 --- a/templates/referenceListing.hamlet +++ b/templates/referenceListing.hamlet | |||
@@ -1,6 +1,7 @@ | |||
1 | <div .table> | 1 | <div .table> |
2 | <div .tr .sepBelow> | 2 | <div .tr .sepBelow> |
3 | <div .th>Item | 3 | <div .th>Item |
4 | <div .th>Type | ||
4 | <div .th>Actions | 5 | <div .th>Actions |
5 | $if isJust (preview insertForm =<< formState) | 6 | $if isJust (preview insertForm =<< formState) |
6 | $with Just InsertForm{..} <- formState | 7 | $with Just InsertForm{..} <- formState |
@@ -9,9 +10,10 @@ | |||
9 | <div .td> | 10 | <div .td> |
10 | <button type=submit> | 11 | <button type=submit> |
11 | Insert | 12 | Insert |
12 | $forall Entity referenceId Reference{..} <- reference | 13 | $forall WithType (Entity referenceId Reference{..}) referenceType <- reference |
13 | <div .tr .color ##{toPathPiece referenceId}> | 14 | <div .tr .color ##{toPathPiece referenceId}> |
14 | <div .kind>#{referenceKind} | 15 | <div .kind>#{referenceKind} |
16 | <div .type>#{referenceType} | ||
15 | <form .td method=post action=@{DeleteRefItemR referenceId}> | 17 | <form .td method=post action=@{DeleteRefItemR referenceId}> |
16 | <button type=submit> | 18 | <button type=submit> |
17 | Delete | 19 | Delete |