Implement old bar.hs

7 files changed, 213 insertions, 0 deletions

diff --git a/Handler/Common.hs b/Handler/Common.hs
new file mode 100644
index 0000000..38fb1ce
--- /dev/null
+++ b/Handler/Common.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE ApplicativeDo #-}
+
+module Handler.Common
+  ( inventoryListing
+  , itemForm
+  , InventoryState(..)
+  , FormState(..)
+  ) where
+
+import Import
+
+import Data.Unique
+
+import qualified Data.Text as Text (pack)
+
+import Control.Lens
+
+import Handler.Common.Types
+
+dayFormat :: Day -> String
+dayFormat = formatTime defaultTimeLocale "%e. %b %y"
+
+itemForm :: Maybe Item -- ^ Update existing item or insert new?
+         -> Html -> MForm Handler (FormResult Item, Widget)
+itemForm proto identView = do
+  today <- utctDay <$> liftIO getCurrentTime
+  
+  (kindRes, kindView) <- mreq textField "" $ 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"
+
+  let itemRes = do
+        itemKind <- kindRes
+        itemBought <- boughtRes
+        itemExpires <- expiresRes
+        itemOpened <- openedRes
+        return Item{ itemNormKind = normalizeKind itemKind, ..}
+
+  return . (itemRes, ) $
+    [whamlet|
+            $newline never
+            #{identView}
+            <div .td>^{fvInput kindView}
+            <div .td>^{boughtWidget}
+            <div .td>^{expiresWidget}
+            <div .td>^{openedWidget}
+            |]
+  where
+    dayForm :: Maybe (Maybe Day) -> String -> MForm Handler (FormResult (Maybe Day), Widget)
+    dayForm proto label = do
+      today <- utctDay <$> liftIO getCurrentTime
+
+      checkboxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique
+      
+      (fmap (fromMaybe False) -> isNothingRes, isNothingView) <-
+        mopt checkBoxField ("" { fsId = Just $ Text.pack checkboxId }) . Just . Just . fromMaybe True $ fmap isNothing proto
+      (dayRes, dayView) <-
+        mreq dayField "" . Just . fromMaybe today $ join proto
+
+      let res = (bool Just (const Nothing) <$> isNothingRes) <*> dayRes
+      return . (res, ) $ do
+        [whamlet|
+                $newline never
+                <div .table>
+                  <div .tr>
+                    <label for=#{checkboxId} .checkbox .td>
+                      ^{fvInput isNothingView}
+                      <span>
+                        #{label}
+                  <div .tr>
+                    <div .td .dayInput>^{fvInput dayView}
+                |]
+
+inventoryListing :: InventoryState -> Widget
+inventoryListing InventoryState{..} = do
+  setTitle "Bar Inventory"
+  $(widgetFile "inventoryListing")
diff --git a/Handler/Common/Types.hs b/Handler/Common/Types.hs
new file mode 100644
index 0000000..ca7cb8d
--- /dev/null
+++ b/Handler/Common/Types.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE FunctionalDependencies #-}
+
+module Handler.Common.Types where
+
+import Import
+
+import Control.Lens
+
+data InventoryState = InventoryState
+  { stock :: [Entity Item]
+  , formState :: Maybe FormState
+  }
+
+data FormState = InsertForm
+                 { fsInsertForm :: Widget
+                 , fsInsertEncoding :: Enctype
+                 }
+               | UpdateForm
+                 { fsUpdateItem :: ItemId
+                 , fsUpdateForm :: Widget
+                 , fsUpdateEncoding :: Enctype
+                 }
+makeLensesWith abbreviatedFields ''FormState
diff --git a/Handler/DeleteItem.hs b/Handler/DeleteItem.hs
new file mode 100644
index 0000000..ee6d9d3
--- /dev/null
+++ b/Handler/DeleteItem.hs
@@ -0,0 +1,10 @@
+module Handler.DeleteItem where
+
+import Import
+
+postDeleteItemR :: ItemId -> Handler TypedContent
+postDeleteItemR itemId = do
+  runDB $ delete itemId
+  selectRep $ do
+    provideJson ()
+    provideRep (redirect $ InventoryListingR :: Handler Html)
diff --git a/Handler/InventoryListing.hs b/Handler/InventoryListing.hs
new file mode 100644
index 0000000..e3c062e
--- /dev/null
+++ b/Handler/InventoryListing.hs
@@ -0,0 +1,26 @@
+module Handler.InventoryListing where
+
+import Import
+import Handler.Common
+
+getInventoryListingR, postInventoryListingR :: Handler TypedContent
+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 []
+
+  (sortOn entityVal -> stock) <- runDB $ selectList [] []
+
+  selectRep $ do
+    provideJson (stock :: [Entity Item])
+    provideRep . defaultLayout $ inventoryListing InventoryState
+      { formState = Just InsertForm{..}
+      , ..
+      }
+
+putInventoryListingR :: Handler Value
+putInventoryListingR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Item)
diff --git a/Handler/Item.hs b/Handler/Item.hs
new file mode 100644
index 0000000..87030bb
--- /dev/null
+++ b/Handler/Item.hs
@@ -0,0 +1,31 @@
+module Handler.Item where
+
+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)
+
+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
+                      ])
+
+patchItemR :: ItemId -> Handler Value
+patchItemR itemId = do
+  diffs <- (requireCheckJsonBody :: Handler ItemDiffs)
+  returnJson . Entity itemId =<< runDB (updateGet itemId $ toUpdate diffs)
+
+deleteItemR :: ItemId -> Handler ()
+deleteItemR = runDB . delete
diff --git a/Handler/OpenItem.hs b/Handler/OpenItem.hs
new file mode 100644
index 0000000..468c6ec
--- /dev/null
+++ b/Handler/OpenItem.hs
@@ -0,0 +1,12 @@
+module Handler.OpenItem where
+
+import Import
+
+postOpenItemR :: ItemId -> Handler TypedContent
+postOpenItemR itemId = do
+  today <- utctDay <$> liftIO getCurrentTime
+  result <- fmap (Entity itemId) . runDB $ updateGet itemId [ ItemOpened =. Just today
+                                                            ]
+  selectRep $ do
+    provideJson result
+    provideRep (redirect $ InventoryListingR :#: itemId :: Handler Html)
diff --git a/Handler/UpdateItem.hs b/Handler/UpdateItem.hs
new file mode 100644
index 0000000..353572b
--- /dev/null
+++ b/Handler/UpdateItem.hs
@@ -0,0 +1,33 @@
+module Handler.UpdateItem where
+
+import Import
+
+import Handler.Common
+
+getUpdateItemR, postUpdateItemR :: ItemId -> Handler TypedContent
+getUpdateItemR = postUpdateItemR
+postUpdateItemR fsUpdateItem = do
+  Just entity <- fmap (Entity fsUpdateItem) <$> runDB (get fsUpdateItem)
+  
+  ((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
+                                                             ])
+    FormFailure errors -> return errors
+    _ -> return []
+
+  selectRep $ do
+    provideRep $ case updateResult of
+      FormSuccess _ -> redirect $ InventoryListingR :#: fsUpdateItem :: Handler Html
+      _ -> do
+        (sortOn entityVal -> stock) <- runDB $ selectList [] []
+        defaultLayout $ inventoryListing InventoryState
+          { formState = Just UpdateForm{..}
+          , ..
+          }
+    provideJson ()