added barcode reader support

This commit is contained in:
nek0 2015-07-21 09:14:38 +02:00
parent 5d160ab8c5
commit 68213ea8df
11 changed files with 211 additions and 33 deletions

View file

@ -3,11 +3,53 @@ module Handler.Barcode where
import Import import Import
import Handler.Common import Handler.Common
import qualified Data.Text as T import qualified Data.Text as T
import Text.Blaze.Internal
import Text.Shakespeare.Text
getHomeBarcodeR :: Handler Html 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 :: 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

View file

@ -3,8 +3,10 @@ module Handler.Common where
import Data.FileEmbed (embedFile) import Data.FileEmbed (embedFile)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.List as L
import qualified Data.Text.Lazy.Encoding as E import qualified Data.Text.Lazy.Encoding as E
import qualified Data.Text.Read as R import qualified Data.Text.Read as R
import Data.Maybe
import Yesod.Form.Functions import Yesod.Form.Functions
import Text.Shakespeare.Text import Text.Shakespeare.Text
import Network.Mail.Mime import Network.Mail.Mime
@ -21,6 +23,12 @@ getRobotsR :: Handler TypedContent
getRobotsR = return $ TypedContent typePlain getRobotsR = return $ TypedContent typePlain
$ toContent $(embedFile "config/robots.txt") $ 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 :: Int -> Text -> Handler ()
updateCashier amount desc = do updateCashier amount desc = do
mCashier <- runDB $ selectFirst [] [Desc CashierId] mCashier <- runDB $ selectFirst [] [Desc CashierId]
@ -73,6 +81,66 @@ volumeField = Field
showVal = either id (pack . showA) showVal = either id (pack . showA)
showA x = show ((fromIntegral x :: Double) / 1000) 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
<input type="text" id="#{theId}" name="#{name}" :isReq:required="" *{attrs} value="#{either id (T.intercalate ", ") val}">
|]
, 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 :: (RenderMessage (HandlerSite m) FormMessage, Show a, Monad m, Integral a) => Field m a
amountField = Field amountField = Field
{ fieldParse = parseHelper $ \s -> { fieldParse = parseHelper $ \s ->

View file

@ -8,7 +8,11 @@ getModifyR bId = do
mBev <- runDB $ get bId mBev <- runDB $ get bId
case mBev of case mBev of
Just bev -> do 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 defaultLayout $ do
$(widgetFile "modify") $(widgetFile "modify")
Nothing -> do Nothing -> do
@ -20,17 +24,19 @@ postModifyR bId = do
mBev <- runDB $ get bId mBev <- runDB $ get bId
case mBev of case mBev of
Just bev -> do 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 case res of
FormSuccess nBev -> do FormSuccess nBev -> do
runDB $ update bId runDB $ update bId
[ BeverageIdent =. beverageIdent nBev [ BeverageIdent =. modBevIdent nBev
, BeveragePrice =. beveragePrice nBev , BeveragePrice =. modBevPrice nBev
, BeverageAmount =. beverageAmount nBev , BeverageAmount =. modBevAmount nBev
, BeverageAlertAmount =. beverageAlertAmount nBev , BeverageAlertAmount =. modBevAlertAmount nBev
, BeverageCorrectedAmount +=. ((beverageAmount nBev) - (beverageAmount bev)) , BeverageCorrectedAmount +=. ((modBevAmount nBev) - (beverageAmount bev))
, BeverageMl =. beverageMl nBev , BeverageMl =. modBevMl nBev
, BeverageAvatar =. beverageAvatar nBev , BeverageAvatar =. modBevAvatar nBev
] ]
setMessageI MsgEditSuccess setMessageI MsgEditSuccess
redirect $ SummaryR redirect $ SummaryR
@ -41,15 +47,25 @@ postModifyR bId = do
setMessageI MsgItemUnknown setMessageI MsgItemUnknown
redirect $ SummaryR redirect $ SummaryR
modifyForm :: Beverage -> Form Beverage data ModBev = ModBev
modifyForm bev = renderDivs $ Beverage { 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 textField (fieldSettingsLabel MsgName) (Just $ beverageIdent bev)
<*> areq currencyField (fieldSettingsLabel MsgPrice) (Just $ beveragePrice bev) <*> areq currencyField (fieldSettingsLabel MsgPrice) (Just $ beveragePrice bev)
<*> areq amountField (fieldSettingsLabel MsgCurrentStock) (Just $ beverageAmount bev) <*> areq amountField (fieldSettingsLabel MsgCurrentStock) (Just $ beverageAmount bev)
<*> areq amountField (fieldSettingsLabel MsgAnnouncedStock) (Just $ beverageAlertAmount bev) <*> areq amountField (fieldSettingsLabel MsgAnnouncedStock) (Just $ beverageAlertAmount bev)
<*> pure (beverageCorrectedAmount bev)
<*> areq volumeField (fieldSettingsLabel MsgVolume) (Just $ beverageMl bev) <*> areq volumeField (fieldSettingsLabel MsgVolume) (Just $ beverageMl bev)
<*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ beverageAvatar bev) <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ beverageAvatar bev)
<*> aopt barcodeField (fieldSettingsLabel MsgBarcodeField) (Just $ Just bs)
where where
avatars = do avatars = do
ents <- runDB $ selectList [] [Asc AvatarIdent] ents <- runDB $ selectList [] [Asc AvatarIdent]

View file

@ -42,6 +42,7 @@ newUserForm secs = renderDivs $ User
data UserConf = UserConf data UserConf = UserConf
{ userConfEmail :: Maybe Text { userConfEmail :: Maybe Text
, userConfAvatar :: Maybe AvatarId , userConfAvatar :: Maybe AvatarId
, userConfBarcode :: Maybe [Text]
} }
getModifyUserR :: UserId -> Handler Html getModifyUserR :: UserId -> Handler Html
@ -49,7 +50,11 @@ getModifyUserR uId = do
mUser <- runDB $ I.get uId mUser <- runDB $ I.get uId
case mUser of case mUser of
Just user -> do 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 defaultLayout $ do
$(widgetFile "modifyUser") $(widgetFile "modifyUser")
Nothing -> do Nothing -> do
@ -61,7 +66,9 @@ postModifyUserR uId = do
mUser <- runDB $ I.get uId mUser <- runDB $ I.get uId
case mUser of case mUser of
Just user -> do 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 case res of
FormSuccess uc -> do FormSuccess uc -> do
runDB $ update uId runDB $ update uId
@ -69,6 +76,7 @@ postModifyUserR uId = do
, UserAvatar =. userConfAvatar uc , UserAvatar =. userConfAvatar uc
] ]
liftIO $ notify user (userConfEmail uc) liftIO $ notify user (userConfEmail uc)
handleBarcodes (Left uId) (fromMaybe [] $ userConfBarcode uc)
setMessageI MsgUserEdited setMessageI MsgUserEdited
redirect $ SelectR uId redirect $ SelectR uId
_ -> do _ -> do
@ -78,10 +86,11 @@ postModifyUserR uId = do
setMessageI MsgUserUnknown setMessageI MsgUserUnknown
redirect $ HomeR redirect $ HomeR
modifyUserForm :: User -> Form UserConf modifyUserForm :: User -> [Text] -> Form UserConf
modifyUserForm user = renderDivs $ UserConf modifyUserForm user bs = renderDivs $ UserConf
<$> aopt emailField (fieldSettingsLabel MsgEmailNotify) (Just $ userEmail user) <$> aopt emailField (fieldSettingsLabel MsgEmailNotify) (Just $ userEmail user)
<*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ userAvatar user) <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ userAvatar user)
<*> aopt barcodeField (fieldSettingsLabel MsgBarcodeField) (Just $ Just bs)
where where
avatars = do avatars = do
ents <- runDB $ selectList [] [Asc AvatarIdent] ents <- runDB $ selectList [] [Asc AvatarIdent]

View file

@ -33,5 +33,12 @@ Avatar
ident Text ident Text
data ByteString data ByteString
deriving Typeable Show 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) -- By default this file is used in Model.hs (which is imported by Foundation.hs)

View file

@ -101,3 +101,10 @@ AvatarDeleted: Avatar úspěšně smazán
AvatarInUseError: Avatar nelze smazat dokud je v užitku AvatarInUseError: Avatar nelze smazat dokud je v užitku
Volume: Objem v l Volume: Objem v l
CorrectedAmount: Stráta 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á

View file

@ -101,3 +101,10 @@ AvatarDeleted: Avatar gelöscht
AvatarInUseError: Avatare können nicht gelöscht werden, solange sie in Benutzung sind. AvatarInUseError: Avatare können nicht gelöscht werden, solange sie in Benutzung sind.
Volume: Volumen in l Volume: Volumen in l
CorrectedAmount: Schwund 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

View file

@ -100,3 +100,11 @@ DeleteAvatar: Delete avatar
AvatarDeleted: Avatar successfully deleted AvatarDeleted: Avatar successfully deleted
AvatarInUseError: You can not delete avatars that are currently in use AvatarInUseError: You can not delete avatars that are currently in use
Volume: Volume in l 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

View file

@ -10,6 +10,13 @@ function showBarcode(text) {
function barcodeKeyPress(event) { function barcodeKeyPress(event) {
var key = String.fromCharCode(event.charCode) var key = String.fromCharCode(event.charCode)
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) { if (event.keyCode === 13) {
var input = document.getElementById('barcodeInput') var input = document.getElementById('barcodeInput')
if (input) { if (input) {
@ -24,4 +31,5 @@ function barcodeKeyPress(event) {
showBarcode(barcodeBuf) showBarcode(barcodeBuf)
event.preventDefault() event.preventDefault()
} }
}
} }

View file

@ -9,3 +9,6 @@ $doctype 5
<a href=@{DeleteBeverageR bId}> <a href=@{DeleteBeverageR bId}>
_{MsgDeleteItem} _{MsgDeleteItem}
<form action=@{ModifyR bId} method=GET>
<input type=hidden #barcodeInput name=barcode>

View file

@ -6,3 +6,6 @@ $doctype 5
^{modifyUserWidget} ^{modifyUserWidget}
<div> <div>
<input type=submit value="_{MsgSubmit}"> <input type=submit value="_{MsgSubmit}">
<form action=@{ModifyUserR uId} method=GET>
<input type=hidden #barcodeInput name=barcode>