From 68213ea8df4cb81878b98810702e3cab005d91f0 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 21 Jul 2015 09:14:38 +0200 Subject: [PATCH] added barcode reader support --- Handler/Barcode.hs | 50 ++++++++++++++++++++++++--- Handler/Common.hs | 68 +++++++++++++++++++++++++++++++++++++ Handler/Modify.hs | 40 +++++++++++++++------- Handler/NewUser.hs | 19 ++++++++--- config/models | 7 ++++ messages/cz.msg | 7 ++++ messages/de.msg | 7 ++++ messages/en.msg | 8 +++++ static/js/barcode.js | 32 ++++++++++------- templates/modify.hamlet | 3 ++ templates/modifyUser.hamlet | 3 ++ 11 files changed, 211 insertions(+), 33 deletions(-) diff --git a/Handler/Barcode.hs b/Handler/Barcode.hs index 7786ef8..1ecb852 100644 --- a/Handler/Barcode.hs +++ b/Handler/Barcode.hs @@ -3,11 +3,53 @@ module Handler.Barcode where import Import import Handler.Common import qualified Data.Text as T -import Text.Blaze.Internal -import Text.Shakespeare.Text getHomeBarcodeR :: Handler Html -getHomeBarcodeR = return mempty +getHomeBarcodeR = do + c <- lookupGetParam "barcode" + case c of + Just code -> do + be <- runDB $ getBy $ UniqueBarcode code + case be of + Just (Entity _ bar) -> do + case barcodeIsUser bar of + True -> do + case barcodeUser bar of + Just uId -> do + redirect $ SelectR uId + Nothing -> do + error "Malformed barcode" + False -> do + setMessageI MsgBarcodeNotUser + redirect HomeR + Nothing -> do + setMessageI MsgBarcodeUnknown + redirect HomeR + Nothing -> do + setMessageI MsgProvideBarcode + redirect HomeR getSelectBarcodeR :: UserId -> Handler Html -getSelectBarcodeR uId = return mempty +getSelectBarcodeR uId = do + c <- lookupGetParam "barcode" + case c of + Just code -> do + be <- runDB $ getBy $ UniqueBarcode code + case be of + Just (Entity _ bar) -> do + case barcodeIsUser bar of + False -> do + case barcodeBev bar of + Just bId -> do + redirect $ BuyR uId bId + Nothing -> do + error "Malformed barcode" + True -> do + setMessageI MsgBarcodeNotBev + redirect $ SelectR uId + Nothing -> do + setMessageI MsgBarcodeUnknown + redirect $ SelectR uId + Nothing -> do + setMessageI MsgProvideBarcode + redirect $ SelectR uId diff --git a/Handler/Common.hs b/Handler/Common.hs index f3f76cd..fc532ab 100644 --- a/Handler/Common.hs +++ b/Handler/Common.hs @@ -3,8 +3,10 @@ module Handler.Common where import Data.FileEmbed (embedFile) import qualified Data.Text as T +import qualified Data.List as L import qualified Data.Text.Lazy.Encoding as E import qualified Data.Text.Read as R +import Data.Maybe import Yesod.Form.Functions import Text.Shakespeare.Text import Network.Mail.Mime @@ -21,6 +23,12 @@ getRobotsR :: Handler TypedContent getRobotsR = return $ TypedContent typePlain $ toContent $(embedFile "config/robots.txt") +removeItem :: Eq a => a -> [a] -> [a] +removeItem _ [] = [] +removeItem x (y:ys) + | x == y = removeItem x ys + | otherwise = y : (removeItem x ys) + updateCashier :: Int -> Text -> Handler () updateCashier amount desc = do mCashier <- runDB $ selectFirst [] [Desc CashierId] @@ -73,6 +81,66 @@ volumeField = Field showVal = either id (pack . showA) showA x = show ((fromIntegral x :: Double) / 1000) +barcodeField = Field + { fieldParse = parseHelper $ Right . removeItem "" . L.nub . T.splitOn ", " + , fieldView = \theId name attrs val isReq -> toWidget [hamlet|$newline never + + |] + , fieldEnctype = UrlEncoded + } + +handleBarcodes :: Either UserId BeverageId -> [Text] -> Handler () +handleBarcodes (Left uId) nbs = do + raws <- runDB $ selectList [BarcodeUser ==. Just uId] [] + obs <- return $ map (barcodeCode . entityVal) raws + case length nbs > length obs of + True -> do + sect <- return $ nbs L.\\ obs + _ <- mapM (\b -> runDB $ insert $ Barcode + b + True + (Just uId) + Nothing + ) sect + return () + False -> do + sect <- return $ obs L.\\ nbs + ents <- mapM (runDB . getBy . UniqueBarcode) sect + mapM_ (runDB . delete . entityKey . fromJust) ents +handleBarcodes (Right bId) nbs = do + raws <- runDB $ selectList [BarcodeBev ==. Just bId] [] + obs <- return $ map (barcodeCode . entityVal) raws + case length nbs > length obs of + True -> do + sect <- return $ nbs L.\\ obs + _ <- mapM (\b -> runDB $ insert $ Barcode + b + False + Nothing + (Just bId) + ) sect + return () + False -> do + sect <- return $ obs L.\\ nbs + ents <- mapM (runDB . getBy . UniqueBarcode) sect + mapM_ (runDB . delete . entityKey . fromJust) ents + +handleGetParam :: Maybe Text -> Either UserId BeverageId -> Handler () +handleGetParam Nothing _ = + return () +handleGetParam (Just b) eub = do + e <- runDB $ getBy $ UniqueBarcode b + case e of + Nothing -> do + _ <- case eub of + Left uId -> do + runDB $ insert_ $ Barcode b True (Just uId) Nothing + Right bId -> do + runDB $ insert_ $ Barcode b False Nothing (Just bId) + setMessageI MsgBarcodeAdded + Just _ -> + setMessageI MsgBarcodeDuplicate + amountField :: (RenderMessage (HandlerSite m) FormMessage, Show a, Monad m, Integral a) => Field m a amountField = Field { fieldParse = parseHelper $ \s -> diff --git a/Handler/Modify.hs b/Handler/Modify.hs index 14643ed..76fc62b 100644 --- a/Handler/Modify.hs +++ b/Handler/Modify.hs @@ -8,7 +8,11 @@ getModifyR bId = do mBev <- runDB $ get bId case mBev of Just bev -> do - (modifyWidget, enctype) <- generateFormPost $ modifyForm bev + p <- lookupGetParam "barcode" + _ <- handleGetParam p (Right bId) + rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] + bs <- return $ map (barcodeCode . entityVal) rawbs + (modifyWidget, enctype) <- generateFormPost $ modifyForm bev bs defaultLayout $ do $(widgetFile "modify") Nothing -> do @@ -20,17 +24,19 @@ postModifyR bId = do mBev <- runDB $ get bId case mBev of Just bev -> do - ((res, _), _) <- runFormPost $ modifyForm bev + rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] + bs <- return $ map (barcodeCode . entityVal) rawbs + ((res, _), _) <- runFormPost $ modifyForm bev bs case res of FormSuccess nBev -> do runDB $ update bId - [ BeverageIdent =. beverageIdent nBev - , BeveragePrice =. beveragePrice nBev - , BeverageAmount =. beverageAmount nBev - , BeverageAlertAmount =. beverageAlertAmount nBev - , BeverageCorrectedAmount +=. ((beverageAmount nBev) - (beverageAmount bev)) - , BeverageMl =. beverageMl nBev - , BeverageAvatar =. beverageAvatar nBev + [ BeverageIdent =. modBevIdent nBev + , BeveragePrice =. modBevPrice nBev + , BeverageAmount =. modBevAmount nBev + , BeverageAlertAmount =. modBevAlertAmount nBev + , BeverageCorrectedAmount +=. ((modBevAmount nBev) - (beverageAmount bev)) + , BeverageMl =. modBevMl nBev + , BeverageAvatar =. modBevAvatar nBev ] setMessageI MsgEditSuccess redirect $ SummaryR @@ -41,15 +47,25 @@ postModifyR bId = do setMessageI MsgItemUnknown redirect $ SummaryR -modifyForm :: Beverage -> Form Beverage -modifyForm bev = renderDivs $ Beverage +data ModBev = ModBev + { modBevIdent :: Text + , modBevPrice :: Int + , modBevAmount :: Int + , modBevAlertAmount :: Int + , modBevMl :: Int + , modBevAvatar :: Maybe AvatarId + , modBevBarcodes :: Maybe [Text] + } + +modifyForm :: Beverage -> [Text] -> Form ModBev +modifyForm bev bs = renderDivs $ ModBev <$> areq textField (fieldSettingsLabel MsgName) (Just $ beverageIdent bev) <*> areq currencyField (fieldSettingsLabel MsgPrice) (Just $ beveragePrice bev) <*> areq amountField (fieldSettingsLabel MsgCurrentStock) (Just $ beverageAmount bev) <*> areq amountField (fieldSettingsLabel MsgAnnouncedStock) (Just $ beverageAlertAmount bev) - <*> pure (beverageCorrectedAmount bev) <*> areq volumeField (fieldSettingsLabel MsgVolume) (Just $ beverageMl bev) <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ beverageAvatar bev) + <*> aopt barcodeField (fieldSettingsLabel MsgBarcodeField) (Just $ Just bs) where avatars = do ents <- runDB $ selectList [] [Asc AvatarIdent] diff --git a/Handler/NewUser.hs b/Handler/NewUser.hs index a50fda0..5f3485e 100644 --- a/Handler/NewUser.hs +++ b/Handler/NewUser.hs @@ -42,6 +42,7 @@ newUserForm secs = renderDivs $ User data UserConf = UserConf { userConfEmail :: Maybe Text , userConfAvatar :: Maybe AvatarId + , userConfBarcode :: Maybe [Text] } getModifyUserR :: UserId -> Handler Html @@ -49,9 +50,13 @@ getModifyUserR uId = do mUser <- runDB $ I.get uId case mUser of Just user -> do - (modifyUserWidget, enctype) <- generateFormPost $ modifyUserForm user + p <- lookupGetParam "barcode" + _ <- handleGetParam p (Left uId) + rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] + bs <- return $ map (barcodeCode . entityVal) rawbs + (modifyUserWidget, enctype) <- generateFormPost $ modifyUserForm user bs defaultLayout $ do - $(widgetFile "modifyUser") + $(widgetFile "modifyUser") Nothing -> do setMessageI MsgUserUnknown redirect $ HomeR @@ -61,7 +66,9 @@ postModifyUserR uId = do mUser <- runDB $ I.get uId case mUser of Just user -> do - ((res, _), _) <- runFormPost $ modifyUserForm user + rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] + bs <- return $ map (barcodeCode . entityVal) rawbs + ((res, _), _) <- runFormPost $ modifyUserForm user bs case res of FormSuccess uc -> do runDB $ update uId @@ -69,6 +76,7 @@ postModifyUserR uId = do , UserAvatar =. userConfAvatar uc ] liftIO $ notify user (userConfEmail uc) + handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc) setMessageI MsgUserEdited redirect $ SelectR uId _ -> do @@ -78,10 +86,11 @@ postModifyUserR uId = do setMessageI MsgUserUnknown redirect $ HomeR -modifyUserForm :: User -> Form UserConf -modifyUserForm user = renderDivs $ UserConf +modifyUserForm :: User -> [Text] -> Form UserConf +modifyUserForm user bs = renderDivs $ UserConf <$> aopt emailField (fieldSettingsLabel MsgEmailNotify) (Just $ userEmail user) <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ userAvatar user) + <*> aopt barcodeField (fieldSettingsLabel MsgBarcodeField) (Just $ Just bs) where avatars = do ents <- runDB $ selectList [] [Asc AvatarIdent] diff --git a/config/models b/config/models index b892e9e..7641baa 100644 --- a/config/models +++ b/config/models @@ -33,5 +33,12 @@ Avatar ident Text data ByteString deriving Typeable Show +Barcode + code Text + isUser Bool + user UserId Maybe + bev BeverageId Maybe + UniqueBarcode code + deriving Show -- By default this file is used in Model.hs (which is imported by Foundation.hs) diff --git a/messages/cz.msg b/messages/cz.msg index a7fcc51..b2dfdaf 100644 --- a/messages/cz.msg +++ b/messages/cz.msg @@ -101,3 +101,10 @@ AvatarDeleted: Avatar úspěšně smazán AvatarInUseError: Avatar nelze smazat dokud je v užitku Volume: Objem v l CorrectedAmount: Stráta +BarcodeNotUser: Tento kód není pro uživatele, ale pro produkt +ProvideBarcode: Prosím zadej kód +BarcodeNotBev: Tento kód není pro produkt, ale pro uživatele +BarcodeUnknown: Tento kód je neznámý +BarcodeField: Čárový kódy +BarcodeAdded: Kód zadán +BarcodeDuplicate: Tento kód se již používá diff --git a/messages/de.msg b/messages/de.msg index ed027d4..f61c2aa 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -101,3 +101,10 @@ AvatarDeleted: Avatar gelöscht AvatarInUseError: Avatare können nicht gelöscht werden, solange sie in Benutzung sind. Volume: Volumen in l CorrectedAmount: Schwund +BarcodeNotUser: Dieser Barcode ist keinem Benutzer zugeordnet, sondern einem Produkt +ProvideBarcode: Bitte Barcode angeben +BarcodeNotBev: Dieser Barcode ist keinem Produkt zugeordnet, sondern einem Benutzer +BarcodeUnknown: Dieser Barcode ist unbekannt +BarcodeField: Barcodes +BarcodeAdded: Barcode erfolgreich hinzugefügt +BarcodeDuplicate: Dieser barcode wird schon verwendet diff --git a/messages/en.msg b/messages/en.msg index e919cee..64f3fd8 100644 --- a/messages/en.msg +++ b/messages/en.msg @@ -100,3 +100,11 @@ DeleteAvatar: Delete avatar AvatarDeleted: Avatar successfully deleted AvatarInUseError: You can not delete avatars that are currently in use Volume: Volume in l +CorrectedAmount: Loss +BarcodeNotUser: This barcode is no user, but a product +ProvideBarcode: Please provide a barcode +BarcodeNotBev: This barcode is no product, but a user +BarcodeUnknown: This barcode is unknown +BarcodeField: Barcodes +BarcodeAdded: barcode succesfully added +BarcodeDuplicate: This barcode is already in use diff --git a/static/js/barcode.js b/static/js/barcode.js index c73aff3..0daad22 100644 --- a/static/js/barcode.js +++ b/static/js/barcode.js @@ -10,18 +10,26 @@ function showBarcode(text) { function barcodeKeyPress(event) { var key = String.fromCharCode(event.charCode) - if (event.keyCode === 13) { - var input = document.getElementById('barcodeInput') - if (input) { - input.setAttribute('value', barcodeBuf) - input.parentNode.submit() - return + var focused = document.activeElement + if (! focused || focused == document.body) { + focused = null + } else if (document.querySelector) { + focused = document.querySelector(":focus") + } + if (focused == null || focused.tagName != "INPUT") { + if (event.keyCode === 13) { + var input = document.getElementById('barcodeInput') + if (input) { + input.setAttribute('value', barcodeBuf) + input.parentNode.submit() + return + } + barcodeBuf = "" + event.preventDefault() + } else { + barcodeBuf += key + showBarcode(barcodeBuf) + event.preventDefault() } - barcodeBuf = "" - event.preventDefault() - } else { - barcodeBuf += key - showBarcode(barcodeBuf) - event.preventDefault() } } diff --git a/templates/modify.hamlet b/templates/modify.hamlet index 7f39b8a..9618be8 100644 --- a/templates/modify.hamlet +++ b/templates/modify.hamlet @@ -9,3 +9,6 @@ $doctype 5 _{MsgDeleteItem} + +
+ diff --git a/templates/modifyUser.hamlet b/templates/modifyUser.hamlet index 58c9508..7af6c38 100644 --- a/templates/modifyUser.hamlet +++ b/templates/modifyUser.hamlet @@ -6,3 +6,6 @@ $doctype 5 ^{modifyUserWidget}
+ + +