From fe5cd6ad6c61eb13ca99acd1b69cd09b84051404 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 15 Mar 2017 14:47:31 +0100
Subject: Support types

---
 Handler/Common.hs           | 43 +++++++++++++++++++++++++++++++++++++++----
 Handler/Common/Types.hs     |  4 ++--
 Handler/InventoryListing.hs | 21 ++++++++++++++-------
 Handler/Item.hs             | 27 ++++++++++++++++-----------
 Handler/List.hs             | 44 ++++++++++++++++++++++++--------------------
 Handler/ReferenceItem.hs    | 17 ++++++++---------
 Handler/ReferenceListing.hs | 21 ++++++++++++++-------
 Handler/UpdateItem.hs       | 23 +++++++++++++----------
 8 files changed, 130 insertions(+), 70 deletions(-)

(limited to 'Handler')

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
 
 import qualified Data.Text as Text (pack)
 
+import Data.Set (Set)
+import qualified Data.Set as Set
+
 import Control.Lens
 
 import Handler.Common.Types
@@ -26,11 +29,14 @@ dayFormat :: Day -> String
 dayFormat = formatTime defaultTimeLocale "%e. %b %y"
 
 itemForm :: Maybe Item -- ^ Update existing item or insert new?
-         -> Html -> MForm Handler (FormResult Item, Widget)
+         -> Html -> MForm Handler (FormResult (WithType Item), Widget)
 itemForm proto identView = do
   today <- utctDay <$> liftIO getCurrentTime
+
+  t <- lift . runDB $ maybe (return Nothing) (fmap (Just . kindType) . getType) proto
   
   (kindRes, kindWidget) <- kindField $ itemKind <$> proto
+  (typeRes, typeWidget) <- typeField $ t
   (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown"
   (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never"
   (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never"
@@ -40,13 +46,15 @@ itemForm proto identView = do
         itemBought <- boughtRes
         itemExpires <- expiresRes
         itemOpened <- openedRes
-        return Item{ itemNormKind = normalizeKind itemKind, ..}
+        t <- typeRes
+        return $ Item{ itemNormKind = normalizeKind itemKind, ..} `WithType` t
 
   return . (itemRes, ) $
     [whamlet|
             $newline never
             #{identView}
             <div .td>^{kindWidget}
+            <div .td>^{typeWidget}
             <div .td>^{boughtWidget}
             <div .td>^{expiresWidget}
             <div .td>^{openedWidget}
@@ -81,19 +89,24 @@ inventoryListing :: InventoryState -> Widget
 inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing")
 
 referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
-              -> Html -> MForm Handler (FormResult Reference, Widget)
+              -> Html -> MForm Handler (FormResult (WithType Reference), Widget)
 referenceForm proto identView = do
+  t <- lift . runDB $ maybe (return Nothing) (fmap (Just . kindType) . getType) proto
+
   (kindRes, kindWidget) <- kindField $ referenceKind <$> proto
+  (typeRes, typeWidget) <- typeField $ t
 
   let referenceRes = do
         referenceKind <- kindRes
-        return Reference{ referenceNormKind = normalizeKind referenceKind, .. }
+        t <- typeRes
+        return $ Reference{ referenceNormKind = normalizeKind referenceKind, .. } `WithType` t
 
   return . (referenceRes, ) $
     [whamlet|
             $newline never
             #{identView}
             <div .td>^{kindWidget}
+            <div .td>^{typeWidget}
             |]
 
 referenceListing :: ReferenceState -> Widget
@@ -121,6 +134,28 @@ kindField proto = do
                 <option value=#{opt}>
             |]
 
+typeField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
+typeField proto = do
+  optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique
+
+  let
+    attrs = [ ("list", optionId)
+            , ("autocomplete", "off")
+            ]
+
+  (typeRes, typeView) <- mreq textField ("" { fsAttrs = attrs }) proto
+
+  (Set.fromList . map (kindType . entityVal) -> options) <- lift . runDB $ selectList [] []
+
+  return . (typeRes, ) $
+    [whamlet|
+            $newline never
+            ^{fvInput typeView}
+            <datalist ##{optionId}>
+              $forall opt <- Set.toList options
+                <option value=#{opt}>
+            |]
+
 kinds :: Handler [Text]
 kinds = do
   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
 import Control.Lens
 
 data InventoryState = InventoryState
-  { stock :: [Entity Item]
+  { stock :: [WithType (Entity Item)]
   , invFormState :: Maybe (FormState ItemId)
   }
 
 data ReferenceState = ReferenceState
-  { reference :: [Entity Reference]
+  { reference :: [WithType (Entity Reference)]
   , refFormState :: Maybe (FormState ReferenceId)
   }
 
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
 postInventoryListingR = do
   ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ itemForm Nothing
 
-  mapM_ (addMessage "formError" . toHtml) =<< case insertResult of 
-    FormSuccess newItem -> [] <$ runDB (insert newItem)
-    FormFailure errors -> return errors
-    _ -> return []
+  case insertResult of 
+    FormSuccess (Item{..} `WithType` t) -> runDB $ do
+      upsertBy (UniqueKind itemNormKind) (Kind itemNormKind t) [ KindType =. t ]
+      insert Item{..}
+      return ()
+    FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
+    _ -> return ()
 
-  (sortOn entityVal -> stock) <- runDB $ selectList [] []
+  (sortOn (entityVal . typedVal) -> stock) <- runDB $ mapM withType =<< selectList [] []
 
   selectRep $ do
-    provideJson (stock :: [Entity Item])
+    provideJson (stock :: [WithType (Entity Item)])
     provideRep . defaultLayout $ inventoryListing InventoryState
       { invFormState = Just InsertForm{..}
       , ..
       }
 
 putInventoryListingR :: Handler Value
-putInventoryListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Item)
+putInventoryListingR = do
+  (Item{..} `WithType` t) <- requireCheckJsonBody
+  returnJson <=< runDB $ do
+    upsertBy (UniqueKind itemNormKind) (Kind itemNormKind t) [ KindType =. t ]
+    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
 
 getItemR :: ItemId -> Handler TypedContent
 getItemR itemId = do
-  entity <- runDB $ Entity itemId <$> get404 itemId
+  entity <- runDB $ withType =<< Entity itemId <$> get404 itemId
   selectRep $ do
     provideJson entity
     provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
 
 putItemR :: ItemId -> Handler Value
 putItemR itemId = do
-  Item{..} <- requireCheckJsonBody
-  returnJson . Entity itemId =<< runDB
-    (updateGet itemId [ ItemKind =. itemKind
-                      , ItemNormKind =. itemNormKind
-                      , ItemBought =. itemBought
-                      , ItemExpires =. itemExpires
-                      , ItemOpened =. itemOpened
-                      ])
+  (Item{..} `WithType` t) <- requireCheckJsonBody
+  returnJson <=< runDB $ do
+    entity <- Entity itemId <$> (updateGet itemId [ ItemKind =. itemKind
+                                                  , ItemNormKind =. itemNormKind
+                                                  , ItemBought =. itemBought
+                                                  , ItemExpires =. itemExpires
+                                                  , ItemOpened =. itemOpened
+                                                  ])
+    update (itemFkType $ entityVal entity) [ KindType =. t ]
+    withType entity
 
 patchItemR :: ItemId -> Handler Value
 patchItemR itemId = do
-  diffs <- (requireCheckJsonBody :: Handler ItemDiffs)
-  returnJson . Entity itemId =<< runDB (updateGet itemId $ toUpdate diffs)
+  (itemUpdates, typeUpdates) <- toUpdate <$> (requireCheckJsonBody :: Handler ItemDiffs)
+  returnJson <=< runDB $ do
+    entity <- Entity itemId <$> updateGet itemId itemUpdates
+    update (itemFkType $ entityVal entity) typeUpdates
+    withType entity
 
 deleteItemR :: ItemId -> Handler ()
 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)
 
 import Thermoprint.Client
 
-list :: Handler (Set Text)
+list :: Handler (Set (WithType Text))
 list = do
-  (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)) " []
+  (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)" []
   return $ Set.fromList kinds
 
-mkPrintout :: Set Text -> Printout
-mkPrintout list = Printout
-  [ Paragraph
-    [Cooked . either id Line . text . Lazy.Text.fromStrict . Text.unlines . map (" - " <>) $ Set.toAscList list 
-    ]
-  ]
+mkPrintout :: Set (WithType Text) -> Printout
+mkPrintout list = Printout ps
+  where
+    ps = Map.foldMapWithKey (fmap (pure . Paragraph . pure . Cooked) . toLines) $ group list
+    group = Map.fromListWith (<>) . fmap (\(kind `WithType` t) -> (t, Set.singleton kind)) . Set.toAscList
+    toLines t (Set.toAscList -> kinds) = either id Line . text . Lazy.Text.fromStrict . Text.unlines $
+      pure t ++ map (" - " <>) kinds
 
 getListR, postListR :: Handler TypedContent
 getListR = postListR
@@ -54,18 +55,21 @@ postListR = do
     _ -> return ()
   
   selectRep $ do
-    provideJson list
+    provideJson $ typeToJSON "item" <$> Set.toAscList list
     provideRep . defaultLayout $
       [whamlet|
-              <div .table .main>
-                <div .tr .sepBelow>
-                  <div .th>Item
-                $forall item <- Set.toAscList list
-                  <div .tr .color>
-                    <div .kind>#{item}
-                <form .tr .sepAbove method=post action=@{ListR} enctype=#{printEnc}>
-                  <div .td>
-                    ^{printView}
-                    <button type=submit :Set.null list:disabled>
-                      Print
+              <table .main>
+                <tr .sepBelow>
+                  <th>Item
+                  <th>Type
+                $forall WithType item itemType <- Set.toAscList list
+                  <tr .color>
+                    <td .kind>#{item}
+                    <td .type>#{itemType}
+                <tr .sepAbove>
+                  <td colspan=2>
+                    <form method=post action=@{ListR} enctype=#{printEnc}>
+                      ^{printView}
+                      <button type=submit :Set.null list:disabled>
+                        Print
               |]
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
 
 getReferenceItemR :: ReferenceId -> Handler TypedContent
 getReferenceItemR referenceId = do
-  entity <- runDB $ Entity referenceId <$> get404 referenceId
+  entity <- runDB $ withType =<< Entity referenceId <$> get404 referenceId
   selectRep $ do
     provideJson entity
     provideRep (redirect $ ReferenceListingR :#: referenceId :: Handler Html)
@@ -12,14 +12,13 @@ getReferenceItemR referenceId = do
 
 putReferenceItemR :: ReferenceId -> Handler Value
 putReferenceItemR referenceId = do
-  Reference{..} <- requireCheckJsonBody
-  returnJson . Entity referenceId =<< runDB
-    (updateGet referenceId [ ReferenceKind =. referenceKind
-                           , ReferenceNormKind =. referenceNormKind
-                           ])
-
-patchReferenceItemR :: ReferenceId -> Handler Value
-patchReferenceItemR = putReferenceItemR -- Just one field
+  (Reference{..} `WithType` t) <- requireCheckJsonBody
+  returnJson <=< runDB $ do
+    entity <- Entity referenceId <$> updateGet referenceId [ ReferenceKind =. referenceKind
+                                                           , ReferenceNormKind =. referenceNormKind
+                                                           ]
+    update (referenceFkType $ entityVal entity) [ KindType =. t ]
+    withType entity
 
 deleteReferenceItemR :: ReferenceId -> Handler ()
 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
 postReferenceListingR = do
   ((insertResult, fsInsertForm), fsInsertEncoding) <- runFormPost $ referenceForm Nothing
 
-  mapM_ (addMessage "formError" . toHtml) =<< case insertResult of 
-    FormSuccess newReference -> [] <$ runDB (insert newReference)
-    FormFailure errors -> return errors
-    _ -> return []
+  case insertResult of 
+    FormSuccess (Reference{..} `WithType` t) -> runDB $ do
+      upsertBy (UniqueKind referenceNormKind) (Kind referenceNormKind t) [ KindType =. t ]
+      insert Reference{..}
+      return ()
+    FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
+    _ -> return ()
 
-  reference <- runDB $ selectList [] [Asc ReferenceKind]
+  reference <- runDB $ mapM withType =<< selectList [] [Asc ReferenceKind]
 
   selectRep $ do
-    provideJson (reference :: [Entity Reference])
+    provideJson (reference :: [WithType (Entity Reference)])
     provideRep . defaultLayout $ referenceListing ReferenceState
       { refFormState = Just InsertForm{..}
       , ..
       }
 
 putReferenceListingR :: Handler Value
-putReferenceListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Reference)
+putReferenceListingR = do
+  (Reference{..} `WithType` referenceType) <- requireCheckJsonBody
+  returnJson <=< runDB $ do
+    upsertBy (UniqueKind referenceNormKind) (Kind referenceNormKind referenceType) [ KindType =. referenceType ]
+    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
   
   ((updateResult, fsUpdateForm), fsUpdateEncoding) <- runFormPost . itemForm . Just $ entityVal entity
 
-  mapM_ (addMessage "formError" . toHtml) =<< case updateResult of 
-    FormSuccess Item{..} -> [] <$ runDB (update fsUpdateId [ ItemKind =. itemKind
-                                                           , ItemNormKind =. normalizeKind itemKind
-                                                           , ItemBought =. itemBought
-                                                           , ItemExpires =. itemExpires
-                                                           , ItemOpened =. itemOpened
-                                                           ])
-    FormFailure errors -> return errors
-    _ -> return []
+  case updateResult of 
+    FormSuccess (Item{..} `WithType` t) -> runDB $ do
+      upsertBy (UniqueKind itemNormKind) (Kind itemNormKind t) [ KindType =. t ]
+      update fsUpdateId [ ItemKind =. itemKind
+                        , ItemNormKind =. itemNormKind
+                        , ItemBought =. itemBought
+                        , ItemExpires =. itemExpires
+                        , ItemOpened =. itemOpened
+                        ]
+      return ()
+    FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
+    _ -> return ()
 
   selectRep $ do
     provideRep $ case updateResult of
       FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateId :: Handler Html
       _ -> do
-        (sortOn entityVal -> stock) <- runDB $ selectList [] []
+        (sortOn (entityVal . typedVal) -> stock) <- runDB $ mapM withType =<< selectList [] []
         defaultLayout $ inventoryListing InventoryState
           { invFormState = Just UpdateForm{..}
           , ..
-- 
cgit v1.2.3