From a91deb0648eaf9e8526236c6e4cf29159567ceeb Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sat, 11 Mar 2017 21:37:45 +0100
Subject: Feature complete bar

---
 bragi/bar.hs | 396 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 385 insertions(+), 11 deletions(-)

(limited to 'bragi')

diff --git a/bragi/bar.hs b/bragi/bar.hs
index 067e5af4..64650779 100755
--- a/bragi/bar.hs
+++ b/bragi/bar.hs
@@ -12,14 +12,22 @@
 {-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE ViewPatterns               #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE ApplicativeDo              #-}
   
 
 import Yesod
 import Database.Persist.Postgresql
+  
 import Control.Monad.Logger (runStderrLoggingT)
 import Control.Monad.Reader
+import Control.Monad.Writer
+import Control.Monad.Trans.Maybe
 
+import Data.Time.Clock
 import Data.Time.Calendar
+import Data.Time.Format
 
 import Data.Text (Text)
 import qualified Data.Text as Text
@@ -27,7 +35,17 @@ import qualified Data.Text as Text
 import Data.Map.Lazy (Map)
 import qualified Data.Map.Lazy as Map
 
+import Data.Set (Set)
+import qualified Data.Set as Set
+
 import Data.Aeson
+import Data.Traversable
+import Data.Maybe
+import Data.Bool
+import Data.String (IsString(..))
+import Data.Unique
+import Data.List (sortOn)
+import Data.Ord
 
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
@@ -36,46 +54,402 @@ Item
     bought Day Maybe
     expires Day Maybe
     opened Day Maybe
-    deriving Show
+    deriving Show Eq
 |]
 
+instance Ord Item where
+  x `compare` y = mconcat
+                  [ (isNothing $ itemOpened x) `compare` (isNothing $ itemOpened y)
+                  , itemOpened x `compare` itemOpened y
+                  , itemExpires x `compare` itemExpires x
+                  , itemKind x `compare` itemKind x
+                  , itemBought x `compare` itemBought x
+                  ]
+
 instance ToJSON Item where
-  toJSON Item{..} = object
+  toJSON Item{..} = object $
     [ "kind" .= itemKind
-    , "bought" .= itemBought
-    , "expires" .= itemExpires
-    , "opened" .= itemOpened
-    ]
+    ] ++ maybe [] (\x -> ["bought" .= x]) itemBought
+    ++ maybe [] (\x -> ["expires" .= x]) itemExpires
+    ++ maybe [] (\x -> ["opened" .= x]) itemOpened
+
+instance FromJSON Item where
+  parseJSON = withObject "Item" $ \obj -> do
+    itemKind <- obj .: "kind"
+    itemBought <- obj .:? "bought"
+    itemExpires <- obj .:? "expires"
+    itemOpened <- obj .:? "opened"
+    return Item{..}
   
 instance ToJSON (Entity Item) where
   toJSON = entityIdToJSON
 
+instance FromJSON (Entity Item) where
+  parseJSON = entityIdFromJSON
+
+data ItemDiff = DiffKind Text
+              | DiffBought (Maybe Day)
+              | DiffExpires (Maybe Day)
+              | DiffOpened (Maybe Day)
+
+newtype ItemDiffs = ItemDiffs [ItemDiff]
 
+instance FromJSON ItemDiffs where
+  parseJSON = withObject "ItemDiff" $ \obj -> fmap ItemDiffs . execWriterT $ do
+    tell =<< maybe [] (pure . DiffKind) <$> lift (obj .:? "kind")
+    tell =<< maybe [] (pure . DiffBought) <$> lift (obj .:! "bought")
+    tell =<< maybe [] (pure . DiffExpires) <$> lift (obj .:! "expires")
+    tell =<< maybe [] (pure . DiffOpened) <$> lift (obj .:! "opened")
+
+toUpdate :: ItemDiffs -> [Update Item]
+toUpdate (ItemDiffs ds) = do
+  x <- ds
+  return $ case x of
+    DiffKind t -> ItemKind =. t
+    DiffBought d -> ItemBought =. d
+    DiffExpires d -> ItemExpires =. d
+    DiffOpened d -> ItemOpened =. d
+
+  
 data BarInventory = BarInventory
   { sqlPool :: ConnectionPool
   }
 
 mkYesod "BarInventory" [parseRoutes|
-/ InventoryR GET
+/ InventoryR GET PUT POST
+/#ItemId ItemR GET PUT PATCH DELETE
+/#ItemId/open OpenItemR POST
+/#ItemId/update UpdateItemR POST GET
+/#ItemId/delete DeleteItemR POST
 |]
 
 instance Yesod BarInventory
 
+instance RenderMessage BarInventory FormMessage where
+  renderMessage _ _ = defaultFormMessage
+
 instance YesodPersist BarInventory where
   type YesodPersistBackend BarInventory = SqlBackend
 
   runDB action = runSqlPool action . sqlPool =<< getYesod
 
 
-main = runStderrLoggingT . withPostgresqlPool "" 5 . runReaderT $ do
+data ViewState = ViewState
+  { errs :: [Text]
+  , insertForm :: Maybe Widget
+  , insertEncoding :: Maybe Enctype
+  , stock :: [Entity Item]
+  , updateItem :: Maybe ItemId
+  , updateForm :: Maybe Widget
+  , updateEncoding :: Maybe Enctype
+  }
+
+
+
+main = runStderrLoggingT . withPostgresqlPool "user=bar dbname=bar" 5 . runReaderT $ do
   sqlPool <- ask
   mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) sqlPool
   liftIO . warpEnv $ BarInventory{..}
 
 
-getInventoryR :: Handler TypedContent
+itemFragment itemId = "item" <> show (fromSqlKey itemId)
+  
+itemForm :: Maybe Item -> 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{..}
+
+  return . (itemRes, ) $ do
+    toWidget
+      [cassius|
+              label.checkbox
+                input
+                  vertical-align: middle
+                span
+                  vertical-align: middle
+              |]
+    -- addScriptRemote "https://cdn.jsdelivr.net/webshim/1.16.0/extras/modernizr-custom.js"
+    addScriptRemote "https://cdn.jsdelivr.net/webshim/1.16.0/polyfiller.js"
+    addScriptRemote "https://cdn.jsdelivr.net/jquery/3.1.1/jquery.js"
+    toWidget
+      [julius|
+             webshims.setOptions("forms-ext", {
+               "widgets": {
+                 "classes": "hide-dropdownbtn"
+               }
+             });
+             webshims.activeLang("en-GB");
+             webshims.polyfill("forms forms-ext");
+             |]
+    [whamlet|
+            #{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}
+                |]
+
+
+
+getInventoryR, postInventoryR :: Handler TypedContent
+postInventoryR = getInventoryR
 getInventoryR = do
-  stock <- runDB $ selectList [] []
+  ((insertResult, (Just -> insertForm)), (Just -> insertEncoding)) <- runFormPost $ itemForm Nothing
+
+  errs <- 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 $ mainView ViewState
+      { updateItem = Nothing
+      , updateForm = Nothing
+      , updateEncoding = Nothing
+      , ..
+      }
+
+postUpdateItemR, getUpdateItemR :: ItemId -> Handler TypedContent
+postUpdateItemR = getUpdateItemR
+getUpdateItemR updateItem = do
+  Just entity <- fmap (Entity updateItem) <$> runDB (get updateItem)
   
+  ((updateResult, (Just -> updateForm)), (Just -> updateEncoding)) <- runFormPost . itemForm . Just $ entityVal entity
+
+  errs <- case updateResult of 
+    FormSuccess Item{..} -> [] <$ runDB (update updateItem [ ItemKind =. itemKind
+                                                           , ItemBought =. itemBought
+                                                           , ItemExpires =. itemExpires
+                                                           , ItemOpened =. itemOpened
+                                                           ])
+    FormFailure errors -> return errors
+    _ -> return []
+
+  selectRep $ do
+    provideRep $ case updateResult of
+      FormSuccess _ -> redirect $ InventoryR :#: itemFragment updateItem :: Handler Html
+      _ -> do
+        (sortOn entityVal -> stock) <- runDB $ selectList [] []
+        mainView ViewState
+          { insertForm = Nothing
+          , insertEncoding = Nothing
+          , updateItem = Just updateItem
+          , ..
+          }
+    provideJson ()
+
+mainView :: ViewState -> Handler Html
+mainView ViewState{..} = defaultLayout $ do 
+    let
+      dayFormat = formatTime defaultTimeLocale "%e. %b %y"
+              
+    setTitle "Bar Inventory"
+    toWidget
+      [cassius|
+              .table
+                display: table
+              .table div
+                vertical-align: middle
+              .td
+                display: table-cell
+                text-align: center
+                padding: 0.25em
+              .tr
+                display: table-row
+              .tc
+                display: table-caption
+                padding: 0.25em
+              .th
+                display: table-cell
+                font-variant: small-caps
+                font-weight: bold
+                text-align: center
+                padding: 0.25em
+              .kind
+                display: table-cell
+                text-align: left
+                padding: 0.25em
+              .table .table .td, .table .table .tc, .table .table .th, .table .table .kind
+                padding: 0
+              .error
+                background-color: #fdd
+                text-align: center
+                color: #c00
+                list-style-type: none
+              button
+                width: 6em
+                display:inline-text
+              .day hr
+                width: 2em
+                border: 1px solid #ddd
+                border-style: solid none solid none
+              .sepBelow > div, .sepAbove > div
+                border: 2px none #ddd
+              .sepBelow > div
+                border-bottom-style: solid
+              .sepAbove > div
+                border-top-style: solid
+              .color:nth-child(even)
+                background-color: #f0f0f0
+              .color:nth-child(odd)
+                background-color: #fff
+              body > div
+                margin: 0 auto
+              .table > h1
+                display: table-caption
+              h1
+                font-size: 1.5em
+                font-weight: bold
+                font-variant: small-caps
+                text-align: center
+                margin:0 0 .5em 0
+              |]
+    toWidget
+      [whamlet|
+              <div .table>
+                <h1>
+                  Inventory
+                $if not $ null errs
+                  <ul .tc .error .sepBelow>
+                  $forall e <- errs
+                    <li>#{e}
+                <div .tr .sepBelow>
+                  <div .th>Description
+                  <div .th>Bought
+                  <div .th>Expires
+                  <div .th>Opened
+                  <div .th>Actions
+                $maybe insertEncoding <- insertEncoding
+                  $maybe insertForm <- insertForm
+                    <form .tr .sepBelow action=@{InventoryR} method=post enctype=#{insertEncoding}>
+                      ^{insertForm}
+                      <div .td>
+                        <button type=submit>
+                          Insert
+                $forall e@(Entity itemId Item{..}) <- stock
+                  $with idN <- fromSqlKey itemId
+                    $if and [ Just itemId == updateItem, isJust updateEncoding, isJust updateForm ]
+                      $maybe updateEncoding <- updateEncoding
+                        $maybe updateForm <- updateForm
+                          <form .tr .color action=@{UpdateItemR itemId}##{itemFragment itemId} method=post enctype=#{updateEncoding} ##{itemFragment itemId}>
+                            ^{updateForm}
+                            <div .td>
+                              <button type=submit>
+                                Save Changes
+                    $else
+                      <div .tr .color ##{itemFragment itemId}>
+                        <div .kind>#{itemKind}
+                        <div .td .day>
+                          $maybe bought <- itemBought
+                            #{dayFormat bought}
+                          $nothing
+                            <hr>
+                        <div .td .day>
+                          $maybe expires <- itemExpires
+                            #{dayFormat expires}
+                          $nothing
+                            <hr>
+                        <div .td .day>
+                          $maybe opened <- itemOpened
+                            #{dayFormat opened}
+                          $nothing
+                            <form method=post action=@{OpenItemR itemId}>
+                              <button type=submit>
+                                Open
+                        <div .td>
+                          <form method=get action=@{UpdateItemR itemId}##{itemFragment itemId}>
+                            <button type=submit>
+                              Alter
+                          <form method=post action=@{DeleteItemR itemId}>
+                            <button type=submit>
+                              Delete
+              |]
+
+putInventoryR :: Handler Value
+putInventoryR = returnJson =<< runDB . insertEntity =<< (requireCheckJsonBody :: Handler Item)
+
+getItemR :: ItemId -> Handler TypedContent
+getItemR itemId = do
+  let getEntity id = fmap (Entity id) <$> get id
+
+  eLookup <- runDB $ getEntity itemId
+
+  case eLookup of
+    Nothing -> notFound
+    Just entity -> do
+      
+      selectRep $ do
+        provideJson entity
+
+patchItemR :: ItemId -> Handler Value
+patchItemR itemId = do
+  diffs <- (requireCheckJsonBody :: Handler ItemDiffs)
+  returnJson . Entity itemId =<< runDB (updateGet itemId $ toUpdate diffs)
+
+putItemR :: ItemId -> Handler Value
+putItemR itemId = do
+  Item{..} <- requireCheckJsonBody
+  returnJson . Entity itemId =<< runDB
+    (updateGet itemId [ ItemKind =. itemKind
+                      , ItemBought =. itemBought
+                      , ItemExpires =. itemExpires
+                      , ItemOpened =. itemOpened
+                      ])
+
+deleteItemR :: ItemId -> Handler ()
+deleteItemR = runDB . delete
+
+postDeleteItemR :: ItemId -> Handler TypedContent
+postDeleteItemR itemId = do
+  runDB $ delete itemId
+  selectRep $ do
+    provideJson ()
+    provideRep (redirect $ InventoryR :: Handler Html)
+
+postOpenItemR :: ItemId -> Handler TypedContent
+postOpenItemR itemId = do
+  today <- utctDay <$> liftIO getCurrentTime
+  result <- fmap (Entity itemId) . runDB $ updateGet itemId [ ItemOpened =. Just today
+                                                            ]
   selectRep $ do
-    provideRep . return . toJSON $ (stock :: [Entity Item])
+    provideJson result
+    provideRep (redirect $ InventoryR :#: itemFragment itemId :: Handler Html)
-- 
cgit v1.2.3