added barcode reader support

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

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
+      <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 = Field
   { fieldParse = parseHelper $ \s ->

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
+            [ 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
           redirect $ SummaryR
@@ -41,15 +47,25 @@ postModifyR bId = do
       setMessageI MsgItemUnknown
       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 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]

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 -> [Text] -> Form UserConf
-modifyUserForm user = renderDivs $ 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]

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)

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á

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

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

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 focused = document.activeElement
-        var input = document.getElementById('barcodeInput')
+    if (! focused || focused == document.body) {
-        if (input) {
+        focused = null
-            input.setAttribute('value', barcodeBuf)
+    } else if (document.querySelector) {
-            input.parentNode.submit()
+        focused = document.querySelector(":focus")
-            return
+    }
+    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()
     }
 }

templates/modify.hamlet

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

templates/modifyUser.hamlet

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