Reference & list

10 files changed, 235 insertions, 25 deletions

diff --git a/Handler/Common.hs b/Handler/Common.hs
index 38fb1ce..2416d15 100644
--- a/Handler/Common.hs
+++ b/Handler/Common.hs
@@ -3,8 +3,13 @@
 module Handler.Common
   ( inventoryListing
   , itemForm
+  , referenceListing
+  , referenceForm
+  , kinds
   , InventoryState(..)
+  , ReferenceState(..)
   , FormState(..)
+  , HasFormState(..)
   ) where
 
 import Import
@@ -25,7 +30,7 @@ itemForm :: Maybe Item -- ^ Update existing item or insert new?
 itemForm proto identView = do
   today <- utctDay <$> liftIO getCurrentTime
   
-  (kindRes, kindView) <- mreq textField "" $ itemKind <$> proto
+  (kindRes, kindWidget) <- kindField $ itemKind <$> proto
   (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"
@@ -41,7 +46,7 @@ itemForm proto identView = do
     [whamlet|
             $newline never
             #{identView}
-            <div .td>^{fvInput kindView}
+            <div .td>^{kindWidget}
             <div .td>^{boughtWidget}
             <div .td>^{expiresWidget}
             <div .td>^{openedWidget}
@@ -73,6 +78,55 @@ itemForm proto identView = do
                 |]
 
 inventoryListing :: InventoryState -> Widget
-inventoryListing InventoryState{..} = do
-  setTitle "Bar Inventory"
-  $(widgetFile "inventoryListing")
+inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing")
+
+referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
+              -> Html -> MForm Handler (FormResult Reference, Widget)
+referenceForm proto identView = do
+  (kindRes, kindWidget) <- kindField $ referenceKind <$> proto
+
+  let referenceRes = do
+        referenceKind <- kindRes
+        return Reference{ referenceNormKind = normalizeKind referenceKind, .. }
+
+  return . (referenceRes, ) $
+    [whamlet|
+            $newline never
+            #{identView}
+            <div .td>^{kindWidget}
+            |]
+
+referenceListing :: ReferenceState -> Widget
+referenceListing ReferenceState{ refFormState = formState, ..} = $(widgetFile "referenceListing")
+
+kindField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
+kindField proto = do
+  optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique
+
+  let
+    attrs = [ ("list", optionId)
+            , ("autocomplete", "off")
+            ]
+  
+  (kindRes, kindView) <- mreq textField ("" { fsAttrs = attrs }) proto
+
+  options <- lift kinds
+
+  return . (kindRes, ) $
+    [whamlet|
+            $newline never
+            ^{fvInput kindView}
+            <datalist ##{optionId}>
+              $forall opt <- options
+                <option value=#{opt}>
+            |]
+
+kinds :: Handler [Text]
+kinds = do
+  stock <- runDB $ selectList [] []
+  reference <- runDB $ selectList [] []
+
+  return $ concat
+    [ [ itemKind | Entity _ Item{..} <- stock ]
+    , [ referenceKind | Entity _ Reference{..} <- reference ]
+    ]
diff --git a/Handler/Common/Types.hs b/Handler/Common/Types.hs
index ca7cb8d..08653af 100644
--- a/Handler/Common/Types.hs
+++ b/Handler/Common/Types.hs
@@ -8,15 +8,32 @@ import Control.Lens
 
 data InventoryState = InventoryState
   { stock :: [Entity Item]
-  , formState :: Maybe FormState
+  , invFormState :: Maybe (FormState ItemId)
   }
 
-data FormState = InsertForm
+data ReferenceState = ReferenceState
+  { reference :: [Entity Reference]
+  , refFormState :: Maybe (FormState ReferenceId)
+  }
+
+class HasFormState a where
+  type family UpdateId a :: *
+  formState :: a -> Maybe (FormState (UpdateId a))
+
+instance HasFormState InventoryState where
+  type UpdateId InventoryState = ItemId
+  formState = invFormState
+
+instance HasFormState ReferenceState where
+  type UpdateId ReferenceState = ReferenceId
+  formState = refFormState
+  
+data FormState id = InsertForm
                  { fsInsertForm :: Widget
                  , fsInsertEncoding :: Enctype
                  }
                | UpdateForm
-                 { fsUpdateItem :: ItemId
+                 { fsUpdateId :: id
                  , fsUpdateForm :: Widget
                  , fsUpdateEncoding :: Enctype
                  }
diff --git a/Handler/DeleteRefItem.hs b/Handler/DeleteRefItem.hs
new file mode 100644
index 0000000..c4ff519
--- /dev/null
+++ b/Handler/DeleteRefItem.hs
@@ -0,0 +1,10 @@
+module Handler.DeleteRefItem where
+
+import Import
+
+postDeleteRefItemR :: ReferenceId -> Handler TypedContent
+postDeleteRefItemR referenceId = do
+  runDB $ delete referenceId
+  selectRep $ do
+    provideJson ()
+    provideRep (redirect $ ReferenceListingR :: Handler Html)
diff --git a/Handler/InventoryListing.hs b/Handler/InventoryListing.hs
index e3c062e..12f36ba 100644
--- a/Handler/InventoryListing.hs
+++ b/Handler/InventoryListing.hs
@@ -18,7 +18,7 @@ postInventoryListingR = do
   selectRep $ do
     provideJson (stock :: [Entity Item])
     provideRep . defaultLayout $ inventoryListing InventoryState
-      { formState = Just InsertForm{..}
+      { invFormState = Just InsertForm{..}
       , ..
       }
 
diff --git a/Handler/Item.hs b/Handler/Item.hs
index 87030bb..0f48261 100644
--- a/Handler/Item.hs
+++ b/Handler/Item.hs
@@ -4,12 +4,10 @@ import Import
 
 getItemR :: ItemId -> Handler TypedContent
 getItemR itemId = do
-  eLookup <- runDB $ fmap (Entity itemId) <$> get itemId
-  case eLookup of
-    Nothing -> notFound
-    Just entity -> selectRep $ do
-      provideJson entity
-      provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
+  entity <- runDB $ Entity itemId <$> get404 itemId
+  selectRep $ do
+    provideJson entity
+    provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
 
 putItemR :: ItemId -> Handler Value
 putItemR itemId = do
diff --git a/Handler/Kinds.hs b/Handler/Kinds.hs
new file mode 100644
index 0000000..0843c70
--- /dev/null
+++ b/Handler/Kinds.hs
@@ -0,0 +1,8 @@
+module Handler.Kinds where
+
+import Import
+
+import Handler.Common
+
+getKindsR :: Handler Value
+getKindsR = returnJson =<< kinds
diff --git a/Handler/List.hs b/Handler/List.hs
new file mode 100644
index 0000000..cfd3f7c
--- /dev/null
+++ b/Handler/List.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE OverloadedLists #-}
+
+module Handler.List where
+
+import Import
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import qualified Data.Text as Text
+import qualified Data.Text.Lazy as Lazy.Text
+
+import Database.Persist.Sql (Single(..), rawSql)
+
+import Thermoprint.Client
+
+list :: Handler (Set 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)) " []
+  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 
+    ]
+  ]
+
+getListR, postListR :: Handler TypedContent
+getListR = postListR
+postListR = do
+  Client{..} <- mkClient' . appThermoprintBase . appSettings <$> getYesod
+  let
+    formatPrinter (pId@(PrinterId num), pStatus) =
+      ("Printer #" <> tshow num <> " – " <> tshow pStatus, pId)
+  printers' <- map formatPrinter . Map.toAscList <$> printers
+  list <- list
+
+  ((printResult, printView), printEnc) <- runFormPost . renderDivsNoLabels $ do
+    pId <- case printers' of
+      [(_, pId)] -> pure pId
+      _ -> areq (selectFieldList printers') "Printer" . listToMaybe $ map snd printers'
+    pure pId
+
+  case printResult of
+    FormSuccess pId -> do
+      (JobId jId) <- jobCreate (Just pId) $ mkPrintout list
+      addMessage "printSuccess" . toHtml $ "List is printing as job #" <> tshow jId
+    FormFailure errors -> mapM_ (addMessage "formError" . toHtml) errors
+    _ -> return ()
+  
+  selectRep $ do
+    provideJson 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
+              |]
diff --git a/Handler/ReferenceItem.hs b/Handler/ReferenceItem.hs
new file mode 100644
index 0000000..738c9f3
--- /dev/null
+++ b/Handler/ReferenceItem.hs
@@ -0,0 +1,25 @@
+module Handler.ReferenceItem where
+
+import Import
+
+getReferenceItemR :: ReferenceId -> Handler TypedContent
+getReferenceItemR referenceId = do
+  entity <- runDB $ Entity referenceId <$> get404 referenceId
+  selectRep $ do
+    provideJson entity
+    provideRep (redirect $ ReferenceListingR :#: referenceId :: Handler Html)
+
+
+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
+
+deleteReferenceItemR :: ReferenceId -> Handler ()
+deleteReferenceItemR = runDB . delete
diff --git a/Handler/ReferenceListing.hs b/Handler/ReferenceListing.hs
new file mode 100644
index 0000000..0f777ee
--- /dev/null
+++ b/Handler/ReferenceListing.hs
@@ -0,0 +1,27 @@
+module Handler.ReferenceListing where
+
+import Import
+
+import Handler.Common
+
+getReferenceListingR, postReferenceListingR :: Handler TypedContent
+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 []
+
+  reference <- runDB $ selectList [] [Asc ReferenceKind]
+
+  selectRep $ do
+    provideJson (reference :: [Entity Reference])
+    provideRep . defaultLayout $ referenceListing ReferenceState
+      { refFormState = Just InsertForm{..}
+      , ..
+      }
+
+putReferenceListingR :: Handler Value
+putReferenceListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Reference)
diff --git a/Handler/UpdateItem.hs b/Handler/UpdateItem.hs
index 353572b..a4a29c2 100644
--- a/Handler/UpdateItem.hs
+++ b/Handler/UpdateItem.hs
@@ -6,28 +6,28 @@ import Handler.Common
 
 getUpdateItemR, postUpdateItemR :: ItemId -> Handler TypedContent
 getUpdateItemR = postUpdateItemR
-postUpdateItemR fsUpdateItem = do
-  Just entity <- fmap (Entity fsUpdateItem) <$> runDB (get fsUpdateItem)
+postUpdateItemR fsUpdateId = do
+  Just entity <- fmap (Entity fsUpdateId) <$> runDB (get fsUpdateId)
   
   ((updateResult, fsUpdateForm), fsUpdateEncoding) <- runFormPost . itemForm . Just $ entityVal entity
 
   mapM_ (addMessage "formError" . toHtml) =<< case updateResult of 
-    FormSuccess Item{..} -> [] <$ runDB (update fsUpdateItem [ ItemKind =. itemKind
-                                                             , ItemNormKind =. normalizeKind itemKind
-                                                             , ItemBought =. itemBought
-                                                             , ItemExpires =. itemExpires
-                                                             , ItemOpened =. itemOpened
-                                                             ])
+    FormSuccess Item{..} -> [] <$ runDB (update fsUpdateId [ ItemKind =. itemKind
+                                                           , ItemNormKind =. normalizeKind itemKind
+                                                           , ItemBought =. itemBought
+                                                           , ItemExpires =. itemExpires
+                                                           , ItemOpened =. itemOpened
+                                                           ])
     FormFailure errors -> return errors
     _ -> return []
 
   selectRep $ do
     provideRep $ case updateResult of
-      FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateItem :: Handler Html
+      FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateId :: Handler Html
       _ -> do
         (sortOn entityVal -> stock) <- runDB $ selectList [] []
         defaultLayout $ inventoryListing InventoryState
-          { formState = Just UpdateForm{..}
+          { invFormState = Just UpdateForm{..}
           , ..
           }
     provideJson ()