summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Handler/Common.hs43
-rw-r--r--Handler/Common/Types.hs4
-rw-r--r--Handler/InventoryListing.hs21
-rw-r--r--Handler/Item.hs27
-rw-r--r--Handler/List.hs44
-rw-r--r--Handler/ReferenceItem.hs17
-rw-r--r--Handler/ReferenceListing.hs21
-rw-r--r--Handler/UpdateItem.hs23
-rw-r--r--Model.hs90
-rw-r--r--config/models10
-rw-r--r--config/routes3
-rw-r--r--templates/default-layout.cassius19
-rw-r--r--templates/inventoryListing.hamlet4
-rw-r--r--templates/referenceListing.hamlet4
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
19import qualified Data.Text as Text (pack) 19import qualified Data.Text as Text (pack)
20 20
21import Data.Set (Set)
22import qualified Data.Set as Set
23
21import Control.Lens 24import Control.Lens
22 25
23import Handler.Common.Types 26import Handler.Common.Types
@@ -26,11 +29,14 @@ dayFormat :: Day -> String
26dayFormat = formatTime defaultTimeLocale "%e. %b %y" 29dayFormat = formatTime defaultTimeLocale "%e. %b %y"
27 30
28itemForm :: Maybe Item -- ^ Update existing item or insert new? 31itemForm :: Maybe Item -- ^ Update existing item or insert new?
29 -> Html -> MForm Handler (FormResult Item, Widget) 32 -> Html -> MForm Handler (FormResult (WithType Item), Widget)
30itemForm proto identView = do 33itemForm 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
81inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing") 89inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing")
82 90
83referenceForm :: Maybe Reference -- ^ Update existing item or insert new? 91referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
84 -> Html -> MForm Handler (FormResult Reference, Widget) 92 -> Html -> MForm Handler (FormResult (WithType Reference), Widget)
85referenceForm proto identView = do 93referenceForm 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
99referenceListing :: ReferenceState -> Widget 112referenceListing :: ReferenceState -> Widget
@@ -121,6 +134,28 @@ kindField proto = do
121 <option value=#{opt}> 134 <option value=#{opt}>
122 |] 135 |]
123 136
137typeField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
138typeField 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
124kinds :: Handler [Text] 159kinds :: Handler [Text]
125kinds = do 160kinds = 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
7import Control.Lens 7import Control.Lens
8 8
9data InventoryState = InventoryState 9data 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
14data ReferenceState = ReferenceState 14data 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
8postInventoryListingR = do 8postInventoryListingR = 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
25putInventoryListingR :: Handler Value 28putInventoryListingR :: Handler Value
26putInventoryListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Item) 29putInventoryListingR = 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
5getItemR :: ItemId -> Handler TypedContent 5getItemR :: ItemId -> Handler TypedContent
6getItemR itemId = do 6getItemR 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
12putItemR :: ItemId -> Handler Value 12putItemR :: ItemId -> Handler Value
13putItemR itemId = do 13putItemR 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
23patchItemR :: ItemId -> Handler Value 25patchItemR :: ItemId -> Handler Value
24patchItemR itemId = do 26patchItemR 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
28deleteItemR :: ItemId -> Handler () 33deleteItemR :: ItemId -> Handler ()
29deleteItemR = runDB . delete 34deleteItemR = 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
19import Thermoprint.Client 19import Thermoprint.Client
20 20
21list :: Handler (Set Text) 21list :: Handler (Set (WithType Text))
22list = do 22list = 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
26mkPrintout :: Set Text -> Printout 26mkPrintout :: Set (WithType Text) -> Printout
27mkPrintout list = Printout 27mkPrintout 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
33getListR, postListR :: Handler TypedContent 34getListR, postListR :: Handler TypedContent
34getListR = postListR 35getListR = 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 Print 71 <form method=post action=@{ListR} enctype=#{printEnc}>
72 ^{printView}
73 <button type=submit :Set.null list:disabled>
74 Print
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
5getReferenceItemR :: ReferenceId -> Handler TypedContent 5getReferenceItemR :: ReferenceId -> Handler TypedContent
6getReferenceItemR referenceId = do 6getReferenceItemR 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
13putReferenceItemR :: ReferenceId -> Handler Value 13putReferenceItemR :: ReferenceId -> Handler Value
14putReferenceItemR referenceId = do 14putReferenceItemR 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 ]
21patchReferenceItemR :: ReferenceId -> Handler Value 21 withType entity
22patchReferenceItemR = putReferenceItemR -- Just one field
23 22
24deleteReferenceItemR :: ReferenceId -> Handler () 23deleteReferenceItemR :: ReferenceId -> Handler ()
25deleteReferenceItemR = runDB . delete 24deleteReferenceItemR = 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
9postReferenceListingR = do 9postReferenceListingR = 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
26putReferenceListingR :: Handler Value 29putReferenceListingR :: Handler Value
27putReferenceListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Reference) 30putReferenceListingR = 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 , ..
diff --git a/Model.hs b/Model.hs
index 7b33f6e..a345f2f 100644
--- a/Model.hs
+++ b/Model.hs
@@ -10,7 +10,10 @@ import Control.Monad.Writer
10import Data.Text (Text) 10import Data.Text (Text)
11import qualified Data.Text as Text 11import qualified Data.Text as Text
12 12
13import qualified Data.HashMap.Lazy as HashMap
14
13import Data.Aeson 15import Data.Aeson
16import 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
19share [mkPersist sqlSettings, mkMigrate "migrateAll"] 22share [mkPersist sqlSettings, mkMigrate "migrateAll"]
20 $(persistFileWith lowerCaseSettings "config/models") 23 $(persistFileWith lowerCaseSettings "config/models")
21 24
25class HasType a where
26 getType :: ( BaseBackend backend ~ SqlBackend
27 , MonadIO m
28 , PersistStoreRead backend
29 ) => a -> ReaderT backend m Kind
30
31instance HasType Item where
32 getType = belongsToJust itemFkType
33
34instance HasType Reference where
35 getType = belongsToJust referenceFkType
36
37instance HasType a => HasType (Entity a) where
38 getType Entity{..} = getType entityVal
39
40withType :: ( BaseBackend backend ~ SqlBackend
41 , MonadIO m
42 , PersistStoreRead backend
43 , HasType a
44 ) => a -> ReaderT backend m (WithType a)
45withType val = (val `WithType`) . kindType <$> getType val
46
22instance Ord Item where 47instance 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
71normalizeKind = Text.strip . Text.toCaseFold 96normalizeKind = Text.strip . Text.toCaseFold
72 97
73data ItemDiff = DiffKind Text 98data 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]
80instance FromJSON ItemDiffs where 106instance 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
87toUpdate :: ItemDiffs -> [Update Item] 114toUpdate :: ItemDiffs -> ([Update Item], [Update Kind])
88toUpdate (ItemDiffs ds) = do 115toUpdate (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
126data WithType a = WithType { typedVal :: a, valType :: Text }
127 deriving (Eq, Ord)
128
129typeToJSON :: ToJSON a
130 => Text -- ^ Key for value, if needed
131 -> WithType a -> Value
132typeToJSON 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
138typeFromJSON :: FromJSON a
139 => Maybe Text -- ^ Key for value, if needed
140 -> Value -> Parser (WithType a)
141typeFromJSON 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
148instance ToJSON (WithType Item) where
149 toJSON = typeToJSON $ error "Item is not serializing correctly"
150
151instance ToJSON (WithType (Entity Item)) where
152 toJSON = typeToJSON $ error "Entity Item is not serializing correctly"
153
154instance ToJSON (WithType Reference) where
155 toJSON = typeToJSON "kind"
156
157instance 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
164instance FromJSON (WithType Item) where
165 parseJSON = typeFromJSON Nothing
166
167instance 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
8Reference 9Reference
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
15Kind
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
36table 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
58body > div 65body > 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