This commit is contained in:
nek0 2015-09-15 00:49:13 +02:00
parent 2d627e91e8
commit 35ae7833c5
16 changed files with 203 additions and 210 deletions

View file

@ -32,29 +32,26 @@ import Text.Printf
prependZero :: Text -> Text prependZero :: Text -> Text
prependZero t0 = if T.null t1 prependZero t0
then t1 | T.null t1 = t1
else if T.head t1 == '.' | T.head t1 == '.' = '0' `T.cons` t1
then '0' `T.cons` t1 | "-." `T.isPrefixOf` t1 = "-0." `T.append` T.drop 2 t1
else if "-." `T.isPrefixOf` t1 | otherwise = t1
then "-0." `T.append` (T.drop 2 t1) where t1 = T.dropWhile (' ' ==) t0
else t1
where t1 = T.dropWhile ((==) ' ') t0
formatFloat :: Double -> Text formatFloat :: Double -> Text
formatFloat d = T.pack (pre ++ t ++ c) formatFloat d = T.pack (pre ++ t ++ c)
where where
t = reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp) t = reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp)
c = "," ++ tail (snd sp) c = "," ++ tail (snd sp)
sp = (break (== '.') (printf "%.2f" (abs d))) sp = break (== '.') (printf "%.2f" (abs d))
pre = case d < 0 of pre = if d < 0
True -> "-" then "-"
False -> "" else ""
-- T.pack . (splitEvery 3) . (printf "%,2f") -- T.pack . (splitEvery 3) . (printf "%,2f")
formatIntCurrency :: Int -> Text formatIntCurrency :: Int -> Text
formatIntCurrency x = formatFloat $ ((fromIntegral x) / 100) formatIntCurrency x = formatFloat $ fromIntegral x / 100
-- | The foundation datatype for your application. This can be a good place to -- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
@ -97,9 +94,9 @@ approotRequest master req =
Nothing -> appRoot $ appSettings master Nothing -> appRoot $ appSettings master
where where
prefix = prefix =
case isSecure req of if isSecure req
True -> "https://" then "https://"
False -> "http://" else "http://"
-- Please see the documentation for the Yesod typeclass. There are a number -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- of settings which can be configured by overriding methods here.
@ -111,7 +108,7 @@ instance Yesod App where
-- Store session data on the client in encrypted cookies, -- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes -- default session idle timeout is 120 minutes
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend makeSessionBackend _ = Just <$> defaultClientSessionBackend
120 -- timeout in minutes 120 -- timeout in minutes
"config/client_session_key.aes" "config/client_session_key.aes"

View file

@ -24,29 +24,29 @@ import Graphics.ImageMagick.MagickWand
getAvatarR :: Handler Html getAvatarR :: Handler Html
getAvatarR = do getAvatarR = do
avatars <- runDB $ selectList [] [Asc AvatarIdent] avatars <- runDB $ selectList [] [Asc AvatarIdent]
defaultLayout $ do defaultLayout $
$(widgetFile "avatars") $(widgetFile "avatars")
getNewAvatarR :: Handler Html getNewAvatarR :: Handler Html
getNewAvatarR = do getNewAvatarR = do
(newAvatarWidget, enctype) <- generateFormPost $ avatarNewForm (newAvatarWidget, enctype) <- generateFormPost avatarNewForm
defaultLayout $ do defaultLayout $
$(widgetFile "newAvatar") $(widgetFile "newAvatar")
postNewAvatarR :: Handler Html postNewAvatarR :: Handler Html
postNewAvatarR = do postNewAvatarR = do
((res, _), _) <- runFormPost $ avatarNewForm ((res, _), _) <- runFormPost avatarNewForm
case res of case res of
FormSuccess na -> do FormSuccess na -> do
raw <- runResourceT $ fileSource (avatarNewFile na) $$ sinkLbs raw <- runResourceT $ fileSource (avatarNewFile na) $$ sinkLbs
thumb <- generateThumb $ B.concat $ L.toChunks raw thumb <- generateThumb $ B.concat $ L.toChunks raw
now <- liftIO $ getCurrentTime now <- liftIO getCurrentTime
runDB $ insert_ $ Avatar (avatarNewIdent na) thumb now runDB $ insert_ $ Avatar (avatarNewIdent na) thumb now
setMessageI MsgAvatarUploadSuccessfull setMessageI MsgAvatarUploadSuccessfull
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessageI MsgErrorOccured setMessageI MsgErrorOccured
redirect $ NewAvatarR redirect NewAvatarR
avatarNewForm :: Form AvatarNew avatarNewForm :: Form AvatarNew
avatarNewForm = renderDivs $ AvatarNew avatarNewForm = renderDivs $ AvatarNew
@ -64,11 +64,11 @@ getModifyAvatarR aId = do
case ma of case ma of
Just avatar -> do Just avatar -> do
(avatarModifyWidget, enctype) <- generateFormPost $ avatarModForm avatar (avatarModifyWidget, enctype) <- generateFormPost $ avatarModForm avatar
defaultLayout $ do defaultLayout $
$(widgetFile "modifyAvatar") $(widgetFile "modifyAvatar")
Nothing -> do Nothing -> do
setMessageI MsgAvatarUnknown setMessageI MsgAvatarUnknown
redirect $ AvatarR redirect AvatarR
postModifyAvatarR :: AvatarId -> Handler Html postModifyAvatarR :: AvatarId -> Handler Html
postModifyAvatarR aId = do postModifyAvatarR aId = do
@ -80,13 +80,13 @@ postModifyAvatarR aId = do
FormSuccess md -> do FormSuccess md -> do
updateAvatar aId md updateAvatar aId md
setMessageI MsgAvatarUpdateSuccessfull setMessageI MsgAvatarUpdateSuccessfull
redirect $ AvatarR redirect AvatarR
_ -> do _ -> do
setMessageI MsgErrorOccured setMessageI MsgErrorOccured
redirect $ ModifyAvatarR aId redirect $ ModifyAvatarR aId
Nothing -> do Nothing -> do
setMessageI MsgAvatarUnknown setMessageI MsgAvatarUnknown
redirect $ HomeR redirect HomeR
avatarModForm :: Avatar -> Form AvatarMod avatarModForm :: Avatar -> Form AvatarMod
avatarModForm a = renderDivs $ AvatarMod avatarModForm a = renderDivs $ AvatarMod
@ -99,7 +99,7 @@ data AvatarMod = AvatarMod
} }
updateAvatar :: AvatarId -> AvatarMod -> Handler () updateAvatar :: AvatarId -> AvatarMod -> Handler ()
updateAvatar aId (AvatarMod ident Nothing) = do updateAvatar aId (AvatarMod ident Nothing) =
runDB $ update aId [AvatarIdent =. ident] runDB $ update aId [AvatarIdent =. ident]
updateAvatar aId (AvatarMod ident (Just fi)) = do updateAvatar aId (AvatarMod ident (Just fi)) = do
raw <- runResourceT $ fileSource fi $$ sinkLbs raw <- runResourceT $ fileSource fi $$ sinkLbs
@ -110,19 +110,18 @@ updateAvatar aId (AvatarMod ident (Just fi)) = do
] ]
generateThumb :: ByteString -> Handler ByteString generateThumb :: ByteString -> Handler ByteString
generateThumb raw = do generateThumb raw =
thumb <- liftIO $ withMagickWandGenesis $ do liftIO $ withMagickWandGenesis $ do
(_, w) <- magickWand (_, w) <- magickWand
readImageBlob w raw readImageBlob w raw
w1 <- getImageWidth w w1 <- getImageWidth w
h1 <- getImageHeight w h1 <- getImageHeight w
h2 <- return 140 let h2 = 140
w2 <- return $ floor (((fromIntegral w1) / (fromIntegral h1)) * (fromIntegral h2) :: Double) let w2 = floor (fromIntegral w1 / fromIntegral h1 * fromIntegral h2 :: Double)
resizeImage w w2 h2 lanczosFilter 1 resizeImage w w2 h2 lanczosFilter 1
setImageCompressionQuality w 95 setImageCompressionQuality w 95
setImageFormat w "png" setImageFormat w "png"
getImageBlob w getImageBlob w
return thumb
getGetAvatarR :: AvatarId -> Handler TypedContent getGetAvatarR :: AvatarId -> Handler TypedContent
getGetAvatarR aId = do getGetAvatarR aId = do
@ -136,14 +135,14 @@ getAvatarDeleteR aId = do
Just _ -> do Just _ -> do
c <- runDB $ selectList [UserAvatar ==. Just aId] [] c <- runDB $ selectList [UserAvatar ==. Just aId] []
d <- runDB $ selectList [BeverageAvatar ==. Just aId] [] d <- runDB $ selectList [BeverageAvatar ==. Just aId] []
case null c && null d of if null c && null d
True -> do then do
runDB $ delete aId runDB $ delete aId
setMessageI MsgAvatarDeleted setMessageI MsgAvatarDeleted
redirect $ HomeR redirect HomeR
False -> do else do
setMessageI MsgAvatarInUseError setMessageI MsgAvatarInUseError
redirect $ AvatarR redirect AvatarR
Nothing -> do Nothing -> do
setMessageI MsgAvatarUnknown setMessageI MsgAvatarUnknown
redirect $ AvatarR redirect AvatarR

View file

@ -21,19 +21,19 @@ getHomeBarcodeR :: Handler Html
getHomeBarcodeR = do getHomeBarcodeR = do
eub <- handleSelectParam eub <- handleSelectParam
case eub of case eub of
Just (Left uId) -> do Just (Left uId) ->
redirect $ SelectR uId redirect $ SelectR uId
Just (Right _) -> do Just (Right _) -> do
setMessageI MsgBarcodeNotUser setMessageI MsgBarcodeNotUser
redirect $ HomeR redirect HomeR
Nothing -> do Nothing ->
redirect $ HomeR redirect HomeR
getSelectBarcodeR :: UserId -> Handler Html getSelectBarcodeR :: UserId -> Handler Html
getSelectBarcodeR uId = do getSelectBarcodeR uId = do
eub <- handleSelectParam eub <- handleSelectParam
case eub of case eub of
Just (Right bId) -> do Just (Right bId) ->
redirect $ BuyR uId bId redirect $ BuyR uId bId
Just (Left _) -> do Just (Left _) -> do
setMessageI MsgBarcodeNotBev setMessageI MsgBarcodeNotBev
@ -45,13 +45,13 @@ getSelectCashBarcodeR :: Handler Html
getSelectCashBarcodeR = do getSelectCashBarcodeR = do
eub <- handleSelectParam eub <- handleSelectParam
case eub of case eub of
Just (Right bId) -> do Just (Right bId) ->
redirect $ BuyCashR bId redirect $ BuyCashR bId
Just (Left _) -> do Just (Left _) -> do
setMessageI MsgBarcodeNotBev setMessageI MsgBarcodeNotBev
redirect $ SelectCashR redirect SelectCashR
Nothing -> do Nothing ->
redirect $ SelectCashR redirect SelectCashR
handleSelectParam :: Handler (Maybe (Either UserId BeverageId)) handleSelectParam :: Handler (Maybe (Either UserId BeverageId))
handleSelectParam = do handleSelectParam = do
@ -60,15 +60,15 @@ handleSelectParam = do
Just code -> do Just code -> do
be <- runDB $ getBy $ UniqueBarcode code be <- runDB $ getBy $ UniqueBarcode code
case be of case be of
Just (Entity _ bar) -> do Just (Entity _ bar) ->
case barcodeIsUser bar of if barcodeIsUser bar
True -> do then
case (barcodeUser bar, barcodeBev bar) of case (barcodeUser bar, barcodeBev bar) of
(Just uId, Nothing) -> (Just uId, Nothing) ->
return $ Just $ Left uId return $ Just $ Left uId
_ -> _ ->
error "Malformed barcode" error "Malformed barcode"
False -> do else
case (barcodeBev bar, barcodeUser bar) of case (barcodeBev bar, barcodeUser bar) of
(Just bId, Nothing) -> (Just bId, Nothing) ->
return $ Just $ Right bId return $ Just $ Right bId

View file

@ -28,11 +28,11 @@ getBuyR uId bId = do
Just (user, bev) -> do Just (user, bev) -> do
master <- getYesod master <- getYesod
(buyWidget, enctype) <- generateFormPost buyForm (buyWidget, enctype) <- generateFormPost buyForm
defaultLayout $ do defaultLayout $
$(widgetFile "buy") $(widgetFile "buy")
Nothing -> do Nothing -> do
setMessageI MsgUserOrArticleUnknown setMessageI MsgUserOrArticleUnknown
redirect $ HomeR redirect HomeR
postBuyR :: UserId -> BeverageId -> Handler Html postBuyR :: UserId -> BeverageId -> Handler Html
postBuyR uId bId = do postBuyR uId bId = do
@ -42,10 +42,13 @@ postBuyR uId bId = do
((res, _), _) <- runFormPost buyForm ((res, _), _) <- runFormPost buyForm
case res of case res of
FormSuccess quant -> do FormSuccess quant -> do
case quant > beverageAmount bev of if quant > beverageAmount bev
False -> do then do
price <- return $ quant * (beveragePrice bev) setMessageI MsgNotEnoughItems
sw <- return $ price > (userBalance user) redirect $ BuyR uId bId
else do
let price = quant * (beveragePrice bev)
let sw = price > (userBalance user)
runDB $ update uId [UserBalance -=. price] runDB $ update uId [UserBalance -=. price]
runDB $ update bId [BeverageAmount -=. quant] runDB $ update bId [BeverageAmount -=. quant]
checkAlert bId checkAlert bId
@ -54,19 +57,16 @@ postBuyR uId bId = do
case sw of case sw of
False -> do False -> do
setMessageI MsgPurchaseSuccess setMessageI MsgPurchaseSuccess
redirect $ HomeR redirect HomeR
True -> do True -> do
setMessageI MsgPurchaseDebtful setMessageI MsgPurchaseDebtful
redirect $ HomeR redirect HomeR
True -> do
setMessageI MsgNotEnoughItems
redirect $ BuyR uId bId
_ -> do _ -> do
setMessageI MsgErrorOccured setMessageI MsgErrorOccured
redirect $ HomeR redirect HomeR
Nothing -> do Nothing -> do
setMessageI MsgUserUnknown setMessageI MsgUserUnknown
redirect $ HomeR redirect HomeR
notifyUser :: User -> Beverage -> Int -> App -> IO () notifyUser :: User -> Beverage -> Int -> App -> IO ()
notifyUser user bev price master = do notifyUser user bev price master = do
@ -92,11 +92,11 @@ getBuyCashR bId = do
Just bev -> do Just bev -> do
master <- getYesod master <- getYesod
(buyCashWidget, enctype) <- generateFormPost buyForm (buyCashWidget, enctype) <- generateFormPost buyForm
defaultLayout $ do defaultLayout $
$(widgetFile "buyCash") $(widgetFile "buyCash")
Nothing -> do Nothing -> do
setMessageI MsgItemUnknown setMessageI MsgItemUnknown
redirect $ HomeR redirect HomeR
postBuyCashR :: BeverageId -> Handler Html postBuyCashR :: BeverageId -> Handler Html
postBuyCashR bId = do postBuyCashR bId = do
@ -106,25 +106,25 @@ postBuyCashR bId = do
((res, _), _) <- runFormPost buyForm ((res, _), _) <- runFormPost buyForm
case res of case res of
FormSuccess quant -> do FormSuccess quant -> do
case quant > beverageAmount bev of if quant > beverageAmount bev
False -> do then do
setMessageI MsgNotEnoughItems
redirect $ BuyCashR bId
else do
master <- getYesod master <- getYesod
price <- return $ quant * (beveragePrice bev + (appCashCharge $ appSettings master)) let price = quant * (beveragePrice bev + appCashCharge (appSettings master))
runDB $ update bId [BeverageAmount -=. quant] runDB $ update bId [BeverageAmount -=. quant]
updateCashier price "Barzahlung" updateCashier price "Barzahlung"
checkAlert bId checkAlert bId
let currency = appCurrency $ appSettings master let currency = appCurrency $ appSettings master
setMessageI $ MsgPurchaseSuccessCash price currency setMessageI $ MsgPurchaseSuccessCash price currency
redirect HomeR redirect HomeR
True -> do
setMessageI MsgNotEnoughItems
redirect $ BuyCashR bId
_ -> do _ -> do
setMessageI MsgItemDisappeared setMessageI MsgItemDisappeared
redirect $ HomeR redirect HomeR
Nothing -> do Nothing -> do
setMessageI MsgItemUnknown setMessageI MsgItemUnknown
redirect $ HomeR redirect HomeR
checkData :: UserId -> BeverageId -> Handler (Maybe (User, Beverage)) checkData :: UserId -> BeverageId -> Handler (Maybe (User, Beverage))
checkData uId bId = do checkData uId bId = do

View file

@ -21,7 +21,7 @@ import Handler.Common
getCashCheckR :: Handler Html getCashCheckR :: Handler Html
getCashCheckR = do getCashCheckR = do
(cashCheckWidget, enctype) <- generateFormPost createCashCheckForm (cashCheckWidget, enctype) <- generateFormPost createCashCheckForm
defaultLayout $ do defaultLayout $
$(widgetFile "cashCheck") $(widgetFile "cashCheck")
postCashCheckR :: Handler Html postCashCheckR :: Handler Html
@ -33,10 +33,10 @@ postCashCheckR = do
runDB $ insert_ c runDB $ insert_ c
runDB $ insert_ $ Cashier (cashCheckBalance c) currentTime runDB $ insert_ $ Cashier (cashCheckBalance c) currentTime
setMessageI MsgCashChecked setMessageI MsgCashChecked
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessageI MsgCashCheckError setMessageI MsgCashCheckError
redirect $ CashCheckR redirect CashCheckR
createCashCheckForm :: Form CashCheck createCashCheckForm :: Form CashCheck
createCashCheckForm = renderDivs $ CashCheck createCashCheckForm = renderDivs $ CashCheck

View file

@ -48,7 +48,7 @@ removeItem x (y: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]
trans <- liftIO $ (\time -> return $ Transaction desc amount time) =<< getCurrentTime trans <- liftIO $ (return . Transaction desc amount) =<< getCurrentTime
case mCashier of case mCashier of
Just entCash -> do Just entCash -> do
runDB $ update (entityKey entCash) [CashierBalance +=. amount] runDB $ update (entityKey entCash) [CashierBalance +=. amount]
@ -62,9 +62,9 @@ getCashierBalance :: Handler Int
getCashierBalance = do getCashierBalance = do
mCashier <- runDB $ selectFirst [] [Desc CashierId] mCashier <- runDB $ selectFirst [] [Desc CashierId]
case mCashier of case mCashier of
Just cashier -> do Just cashier ->
return $ cashierBalance $ entityVal cashier return $ cashierBalance $ entityVal cashier
Nothing -> do Nothing ->
return 0 return 0
currencyField :: (RenderMessage (HandlerSite m) FormMessage, Show a, Monad m, Integral a) => Field m a currencyField :: (RenderMessage (HandlerSite m) FormMessage, Show a, Monad m, Integral a) => Field m a
@ -108,10 +108,10 @@ barcodeField = Field
handleBarcodes :: Either UserId BeverageId -> [Text] -> Handler () handleBarcodes :: Either UserId BeverageId -> [Text] -> Handler ()
handleBarcodes (Left uId) nbs = do handleBarcodes (Left uId) nbs = do
raws <- runDB $ selectList [BarcodeUser ==. Just uId] [] raws <- runDB $ selectList [BarcodeUser ==. Just uId] []
obs <- return $ map (barcodeCode . entityVal) raws let obs = map (barcodeCode . entityVal) raws
toDel <- return $ obs L.\\ nbs let toDel = obs L.\\ nbs
toAdd <- return $ nbs L.\\ obs let toAdd = nbs L.\\ obs
_ <- mapM (\b -> runDB $ insert_ $ Barcode mapM_ (\b -> runDB $ insert_ $ Barcode
b b
True True
(Just uId) (Just uId)
@ -121,10 +121,10 @@ handleBarcodes (Left uId) nbs = do
mapM_ (runDB . delete . entityKey . fromJust) ents mapM_ (runDB . delete . entityKey . fromJust) ents
handleBarcodes (Right bId) nbs = do handleBarcodes (Right bId) nbs = do
raws <- runDB $ selectList [BarcodeBev ==. Just bId] [] raws <- runDB $ selectList [BarcodeBev ==. Just bId] []
obs <- return $ map (barcodeCode . entityVal) raws let obs = map (barcodeCode . entityVal) raws
toDel <- return $ obs L.\\ nbs let toDel = obs L.\\ nbs
toAdd <- return $ nbs L.\\ obs let toAdd = nbs L.\\ obs
_ <- mapM (\b -> runDB $ insert $ Barcode mapM_ (\b -> runDB $ insert_ $ Barcode
b b
False False
Nothing Nothing
@ -138,11 +138,11 @@ handleGetParam Nothing _ =
return () return ()
handleGetParam (Just b) eub = do handleGetParam (Just b) eub = do
f <- return $ T.filter C.isAlphaNum b f <- return $ T.filter C.isAlphaNum b
case (T.length f) > 0 && b /= ", " of if T.length f > 0 && b /= ", "
True -> do then do
e <- runDB $ getBy $ UniqueBarcode f e <- runDB $ getBy $ UniqueBarcode f
case e of if isNothing e
Nothing -> do then do
_ <- case eub of _ <- case eub of
Left uId -> do Left uId -> do
-- should usernames containing, among other, spaces cause problems, replace b for f here -- should usernames containing, among other, spaces cause problems, replace b for f here
@ -151,9 +151,9 @@ handleGetParam (Just b) eub = do
-- and here -- and here
runDB $ insert_ $ Barcode b False Nothing (Just bId) runDB $ insert_ $ Barcode b False Nothing (Just bId)
setMessageI MsgBarcodeAdded setMessageI MsgBarcodeAdded
Just _ -> else
setMessageI MsgBarcodeDuplicate setMessageI MsgBarcodeDuplicate
False -> do else
setMessageI MsgProvideBarcode setMessageI MsgProvideBarcode
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
@ -174,10 +174,10 @@ amountField = Field
checkAlert :: BeverageId -> Handler () checkAlert :: BeverageId -> Handler ()
checkAlert bId = do checkAlert bId = do
bev <- runDB $ getJust bId bev <- runDB $ getJust bId
case beverageAmount bev < beverageAlertAmount bev of if beverageAmount bev < beverageAlertAmount bev
True -> do then do
master <- getYesod master <- getYesod
to <- return $ appEmail $ appSettings master let to = appEmail $ appSettings master
liftIO $ sendMail to "Niedriger Bestand" liftIO $ sendMail to "Niedriger Bestand"
[stext| [stext|
Hallo, Hallo,
@ -189,7 +189,8 @@ Viele Grüße,
der Matemat der Matemat
|] |]
False -> return () -- do nothing else
return () -- do nothing
--sendMail :: MonadIO m => Text -> Text -> Text -> m () --sendMail :: MonadIO m => Text -> Text -> Text -> m ()
sendMail to subject body = sendMail to subject body =
@ -211,4 +212,4 @@ sendMail to subject body =
} }
formatIntVolume :: Int -> Text formatIntVolume :: Int -> Text
formatIntVolume x = formatFloat $ ((fromIntegral x) / 1000) formatIntVolume x = formatFloat (fromIntegral x / 1000)

View file

@ -30,21 +30,17 @@ getHomeR :: Handler Html
getHomeR = do getHomeR = do
beverages <- runDB $ selectList [BeverageAmount !=. 0] [Desc BeverageIdent] beverages <- runDB $ selectList [BeverageAmount !=. 0] [Desc BeverageIdent]
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
secs <- return $ (R.read $ formatTime defaultTimeLocale "%s" time) - 2592000 let secs = R.read (formatTime defaultTimeLocale "%s" time) - 2592000
users <- runDB $ selectList [UserTimestamp >=. secs] [Asc UserIdent] users <- runDB $ selectList [UserTimestamp >=. secs] [Asc UserIdent]
defaultLayout $ do defaultLayout $
$(widgetFile "home") $(widgetFile "home")
postHomeR :: Handler Html
postHomeR = do
error "Not yet implemented"
getReactivateR :: Handler Html getReactivateR :: Handler Html
getReactivateR = do getReactivateR = do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
secs <- return $ (R.read $ formatTime defaultTimeLocale "%s" time) - 2592000 let secs = R.read (formatTime defaultTimeLocale "%s" time) - 2592000
users <- runDB $ selectList [UserTimestamp <. secs] [Asc UserIdent] users <- runDB $ selectList [UserTimestamp <. secs] [Asc UserIdent]
defaultLayout $ do defaultLayout $
$(widgetFile "reactivate") $(widgetFile "reactivate")
getUserReactivateR :: UserId -> Handler Html getUserReactivateR :: UserId -> Handler Html
@ -53,10 +49,10 @@ getUserReactivateR uId = do
case mUser of case mUser of
Just user -> do Just user -> do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
secs <- return $ R.read $ formatTime defaultTimeLocale "%s" time let secs = R.read $ formatTime defaultTimeLocale "%s" time
runDB $ update uId [UserTimestamp =. secs] runDB $ update uId [UserTimestamp =. secs]
setMessageI MsgUserReactivated setMessageI MsgUserReactivated
redirect $ HomeR redirect HomeR
Nothing -> do Nothing -> do
setMessageI MsgUserUnknown setMessageI MsgUserUnknown
redirect $ HomeR redirect HomeR

View file

@ -24,15 +24,15 @@ getJournalR = do
master <- getYesod master <- getYesod
rawEntries <- runDB $ selectList [] [Desc TransactionId] rawEntries <- runDB $ selectList [] [Desc TransactionId]
next <- runDB $ selectList [] [Desc TransactionId, OffsetBy 30] next <- runDB $ selectList [] [Desc TransactionId, OffsetBy 30]
entries <- return $ L.reverse $ L.take 30 rawEntries let entries = L.reverse $ L.take 30 rawEntries
total <- return $ L.sum $ I.map (transactionAmount . entityVal) rawEntries let total = L.sum $ I.map (transactionAmount . entityVal) rawEntries
timeLimit <- case L.null entries of timeLimit <- if L.null entries
False -> return $ transactionTime $ entityVal $ L.head $ entries then liftIO getCurrentTime
True -> liftIO getCurrentTime else return $ transactionTime $ entityVal $ L.head entries
cashChecks <- runDB $ selectList [CashCheckTime >=. timeLimit] [Asc CashCheckId] cashChecks <- runDB $ selectList [CashCheckTime >=. timeLimit] [Asc CashCheckId]
list <- return $ merge entries cashChecks let list = merge entries cashChecks
cashBalance <- getCashierBalance cashBalance <- getCashierBalance
defaultLayout $ do defaultLayout $
$(widgetFile "journal") $(widgetFile "journal")
merge :: [Entity Transaction] -> [Entity CashCheck] -> [Either Transaction CashCheck] merge :: [Entity Transaction] -> [Entity CashCheck] -> [Either Transaction CashCheck]
@ -48,14 +48,14 @@ getJournalPageR p = do
master <- getYesod master <- getYesod
rawEntries <- runDB $ selectList [] [Desc TransactionId, OffsetBy (p * 30)] rawEntries <- runDB $ selectList [] [Desc TransactionId, OffsetBy (p * 30)]
next <- runDB $ selectList [] [Desc TransactionId, OffsetBy ((p + 1) * 30)] next <- runDB $ selectList [] [Desc TransactionId, OffsetBy ((p + 1) * 30)]
entries <- return $ L.reverse $ L.take 30 rawEntries let entries = L.reverse $ L.take 30 rawEntries
lTimeLimit <- case L.null entries of lTimeLimit <- if L.null entries
False -> return $ transactionTime $ entityVal $ L.head $ entries then liftIO getCurrentTime
True -> liftIO getCurrentTime else return $ transactionTime $ entityVal $ L.head entries
uTimeLimit <- case L.null entries of uTimeLimit <- if L.null entries
False -> return $ transactionTime $ entityVal $ L.last $ entries then liftIO getCurrentTime
True -> liftIO getCurrentTime else return $ transactionTime $ entityVal $ L.last entries
cashChecks <- runDB $ selectList [CashCheckTime >=. lTimeLimit, CashCheckTime <. uTimeLimit] [Asc CashCheckId] cashChecks <- runDB $ selectList [CashCheckTime >=. lTimeLimit, CashCheckTime <. uTimeLimit] [Asc CashCheckId]
list <- return $ merge entries cashChecks let list = merge entries cashChecks
defaultLayout $ do defaultLayout $
$(widgetFile "journalPage") $(widgetFile "journalPage")

View file

@ -26,13 +26,13 @@ getModifyR bId = do
p <- lookupGetParam "barcode" p <- lookupGetParam "barcode"
_ <- handleGetParam p (Right bId) _ <- handleGetParam p (Right bId)
rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] []
bs <- return $ map (barcodeCode . entityVal) rawbs let bs = map (barcodeCode . entityVal) rawbs
(modifyWidget, enctype) <- generateFormPost $ modifyForm bev bs (modifyWidget, enctype) <- generateFormPost $ modifyForm bev bs
defaultLayout $ do defaultLayout $
$(widgetFile "modify") $(widgetFile "modify")
Nothing -> do Nothing -> do
setMessageI MsgItemUnknown setMessageI MsgItemUnknown
redirect $ SummaryR redirect SummaryR
postModifyR :: BeverageId -> Handler Html postModifyR :: BeverageId -> Handler Html
postModifyR bId = do postModifyR bId = do
@ -40,7 +40,7 @@ postModifyR bId = do
case mBev of case mBev of
Just bev -> do Just bev -> do
rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] [] rawbs <- runDB $ selectList [BarcodeBev ==. Just bId] []
bs <- return $ map (barcodeCode . entityVal) rawbs let bs = map (barcodeCode . entityVal) rawbs
((res, _), _) <- runFormPost $ modifyForm bev bs ((res, _), _) <- runFormPost $ modifyForm bev bs
case res of case res of
FormSuccess nBev -> do FormSuccess nBev -> do
@ -49,19 +49,19 @@ postModifyR bId = do
, BeveragePrice =. modBevPrice nBev , BeveragePrice =. modBevPrice nBev
, BeverageAmount =. modBevAmount nBev , BeverageAmount =. modBevAmount nBev
, BeverageAlertAmount =. modBevAlertAmount nBev , BeverageAlertAmount =. modBevAlertAmount nBev
, BeverageCorrectedAmount +=. ((modBevAmount nBev) - (beverageAmount bev)) , BeverageCorrectedAmount +=. (modBevAmount nBev - beverageAmount bev)
, BeverageMl =. modBevMl nBev , BeverageMl =. modBevMl nBev
, BeverageAvatar =. modBevAvatar nBev , BeverageAvatar =. modBevAvatar nBev
] ]
handleBarcodes (Right bId) (fromMaybe [] $ modBevBarcodes nBev) handleBarcodes (Right bId) (fromMaybe [] $ modBevBarcodes nBev)
setMessageI MsgEditSuccess setMessageI MsgEditSuccess
redirect $ SummaryR redirect SummaryR
_ -> do _ -> do
setMessageI MsgEditFail setMessageI MsgEditFail
redirect $ SummaryR redirect SummaryR
Nothing -> do Nothing -> do
setMessageI MsgItemUnknown setMessageI MsgItemUnknown
redirect $ SummaryR redirect SummaryR
data ModBev = ModBev data ModBev = ModBev
{ modBevIdent :: Text { modBevIdent :: Text
@ -85,7 +85,7 @@ modifyForm bev bs = renderDivs $ ModBev
where where
avatars = do avatars = do
ents <- runDB $ selectList [] [Asc AvatarIdent] ents <- runDB $ selectList [] [Asc AvatarIdent]
optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents optionsPairs $ map (\ent -> (avatarIdent $ entityVal ent, entityKey ent)) ents
getDeleteBeverageR :: BeverageId -> Handler Html getDeleteBeverageR :: BeverageId -> Handler Html
getDeleteBeverageR bId = do getDeleteBeverageR bId = do
@ -94,7 +94,7 @@ getDeleteBeverageR bId = do
Just bev -> do Just bev -> do
runDB $ delete bId runDB $ delete bId
setMessageI MsgItemDeleted setMessageI MsgItemDeleted
redirect $ HomeR redirect HomeR
Nothing -> do Nothing -> do
setMessageI MsgItemUnknown setMessageI MsgItemUnknown
redirect $ HomeR redirect HomeR

View file

@ -23,24 +23,24 @@ import Text.Shakespeare.Text
getNewUserR :: Handler Html getNewUserR :: Handler Html
getNewUserR = do getNewUserR = do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
secs <- return $ read $ formatTime defaultTimeLocale "%s" time let secs = read $ formatTime defaultTimeLocale "%s" time
(newUserWidget, enctype) <- generateFormPost $ newUserForm secs (newUserWidget, enctype) <- generateFormPost $ newUserForm secs
defaultLayout $ do defaultLayout $
$(widgetFile "newUser") $(widgetFile "newUser")
postNewUserR :: Handler Html postNewUserR :: Handler Html
postNewUserR = do postNewUserR = do
time <- liftIO getCurrentTime time <- liftIO getCurrentTime
secs <- return $ read $ formatTime defaultTimeLocale "%s" time let secs = read $ formatTime defaultTimeLocale "%s" time
((res, _), _) <- runFormPost $ newUserForm secs ((res, _), _) <- runFormPost $ newUserForm secs
case res of case res of
FormSuccess user -> do FormSuccess user -> do
_ <- runDB $ insert user runDB $ insert_ user
setMessageI MsgUserCreated setMessageI MsgUserCreated
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessageI MsgUserNotCreated setMessageI MsgUserNotCreated
redirect $ NewUserR redirect NewUserR
newUserForm :: Int -> Form User newUserForm :: Int -> Form User
newUserForm secs = renderDivs $ User newUserForm secs = renderDivs $ User
@ -68,13 +68,13 @@ getModifyUserR uId = do
p <- lookupGetParam "barcode" p <- lookupGetParam "barcode"
_ <- handleGetParam p (Left uId) _ <- handleGetParam p (Left uId)
rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
bs <- return $ map (barcodeCode . entityVal) rawbs let bs = map (barcodeCode . entityVal) rawbs
(modifyUserWidget, enctype) <- generateFormPost $ modifyUserForm user bs (modifyUserWidget, enctype) <- generateFormPost $ modifyUserForm user bs
defaultLayout $ do defaultLayout $
$(widgetFile "modifyUser") $(widgetFile "modifyUser")
Nothing -> do Nothing -> do
setMessageI MsgUserUnknown setMessageI MsgUserUnknown
redirect $ HomeR redirect HomeR
postModifyUserR :: UserId -> Handler Html postModifyUserR :: UserId -> Handler Html
postModifyUserR uId = do postModifyUserR uId = do
@ -82,7 +82,7 @@ postModifyUserR uId = do
case mUser of case mUser of
Just user -> do Just user -> do
rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] [] rawbs <- runDB $ selectList [BarcodeUser ==. Just uId] []
bs <- return $ map (barcodeCode . entityVal) rawbs let bs = map (barcodeCode . entityVal) rawbs
((res, _), _) <- runFormPost $ modifyUserForm user bs ((res, _), _) <- runFormPost $ modifyUserForm user bs
case res of case res of
FormSuccess uc -> do FormSuccess uc -> do
@ -99,7 +99,7 @@ postModifyUserR uId = do
redirect $ SelectR uId redirect $ SelectR uId
Nothing -> do Nothing -> do
setMessageI MsgUserUnknown setMessageI MsgUserUnknown
redirect $ HomeR redirect HomeR
modifyUserForm :: User -> [Text] -> Form UserConf modifyUserForm :: User -> [Text] -> Form UserConf
modifyUserForm user bs = renderDivs $ UserConf modifyUserForm user bs = renderDivs $ UserConf

View file

@ -27,7 +27,7 @@ data Payment = Payment
getPayoutR :: Handler Html getPayoutR :: Handler Html
getPayoutR = do getPayoutR = do
(payoutWidget, enctype) <- generateFormPost payoutForm (payoutWidget, enctype) <- generateFormPost payoutForm
defaultLayout $ do defaultLayout $
$(widgetFile "payout") $(widgetFile "payout")
postPayoutR :: Handler Html postPayoutR :: Handler Html
@ -38,10 +38,10 @@ postPayoutR = do
msg <- renderMessage' $ MsgPayout $ paymentDesc payment msg <- renderMessage' $ MsgPayout $ paymentDesc payment
updateCashier (- (paymentAmount payment)) msg updateCashier (- (paymentAmount payment)) msg
setMessageI MsgPaidOut setMessageI MsgPaidOut
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessageI MsgNotPaidOut setMessageI MsgNotPaidOut
redirect $ JournalR redirect JournalR
payoutForm :: Form Payment payoutForm :: Form Payment
payoutForm = renderDivs $ Payment payoutForm = renderDivs $ Payment

View file

@ -21,7 +21,7 @@ import Handler.Common
getRestockR :: Handler Html getRestockR :: Handler Html
getRestockR = do getRestockR = do
beverages <- runDB $ selectList [] [Asc BeverageIdent] beverages <- runDB $ selectList [] [Asc BeverageIdent]
defaultLayout $ do defaultLayout $
$(widgetFile "restock") $(widgetFile "restock")
getUpstockR :: BeverageId -> Handler Html getUpstockR :: BeverageId -> Handler Html
@ -30,26 +30,26 @@ getUpstockR bId = do
case mBev of case mBev of
Just bev -> do Just bev -> do
(upstockWidget, enctype) <- generateFormPost upstockForm (upstockWidget, enctype) <- generateFormPost upstockForm
defaultLayout $ do defaultLayout $
$(widgetFile "upstock") $(widgetFile "upstock")
Nothing -> do Nothing -> do
setMessageI MsgItemUnknown setMessageI MsgItemUnknown
redirect $ HomeR redirect HomeR
postUpstockR :: BeverageId -> Handler Html postUpstockR :: BeverageId -> Handler Html
postUpstockR bId = do postUpstockR bId = do
mBev <- runDB $ get bId mBev <- runDB $ get bId
case mBev of case mBev of
Just bev -> do Just _ -> do
((res, _), _) <- runFormPost upstockForm ((res, _), _) <- runFormPost upstockForm
case res of case res of
FormSuccess c -> do FormSuccess c ->
case c > 0 of if c > 0
True -> do then do
runDB $ update bId [BeverageAmount +=. c] runDB $ update bId [BeverageAmount +=. c]
setMessageI MsgStockedUp setMessageI MsgStockedUp
redirect $ HomeR redirect HomeR
False -> do else do
setMessageI MsgNotStockedUp setMessageI MsgNotStockedUp
redirect $ UpstockR bId redirect $ UpstockR bId
_ -> do _ -> do
@ -57,7 +57,7 @@ postUpstockR bId = do
redirect $ UpstockR bId redirect $ UpstockR bId
Nothing -> do Nothing -> do
setMessageI MsgItemUnknown setMessageI MsgItemUnknown
redirect $ HomeR redirect HomeR
upstockForm :: Form Int upstockForm :: Form Int
upstockForm = renderDivs upstockForm = renderDivs
@ -66,7 +66,7 @@ upstockForm = renderDivs
getNewArticleR :: Handler Html getNewArticleR :: Handler Html
getNewArticleR = do getNewArticleR = do
(newArticleWidget, enctype) <- generateFormPost newArticleForm (newArticleWidget, enctype) <- generateFormPost newArticleForm
defaultLayout $ do defaultLayout $
$(widgetFile "newArticle") $(widgetFile "newArticle")
postNewArticleR :: Handler Html postNewArticleR :: Handler Html
@ -76,10 +76,10 @@ postNewArticleR = do
FormSuccess bev -> do FormSuccess bev -> do
runDB $ insert_ bev runDB $ insert_ bev
setMessageI MsgItemAdded setMessageI MsgItemAdded
redirect $ HomeR redirect HomeR
_ -> do _ -> do
setMessageI MsgItemNotAdded setMessageI MsgItemNotAdded
redirect $ HomeR redirect HomeR
newArticleForm :: Form Beverage newArticleForm :: Form Beverage
newArticleForm = renderDivs $ Beverage newArticleForm = renderDivs $ Beverage
@ -93,4 +93,4 @@ newArticleForm = renderDivs $ Beverage
where where
avatars = do avatars = do
ents <- runDB $ selectList [] [Asc AvatarIdent] ents <- runDB $ selectList [] [Asc AvatarIdent]
optionsPairs $ map (\ent -> ((avatarIdent $ entityVal ent), entityKey ent)) ents optionsPairs $ map (\ent -> (avatarIdent $ entityVal ent, entityKey ent)) ents

View file

@ -28,16 +28,16 @@ getSelectR uId = do
Just user -> do Just user -> do
master <- getYesod master <- getYesod
beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent] beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent]
defaultLayout $ do defaultLayout $
$(widgetFile "select") $(widgetFile "select")
Nothing -> do Nothing -> do
setMessageI MsgUserUnknown setMessageI MsgUserUnknown
redirect $ HomeR redirect HomeR
getSelectCashR :: Handler Html getSelectCashR :: Handler Html
getSelectCashR = do getSelectCashR = do
beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent] beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent]
defaultLayout $ do defaultLayout $
$(widgetFile "selectCash") $(widgetFile "selectCash")
getRechargeR :: UserId -> Handler Html getRechargeR :: UserId -> Handler Html
@ -47,11 +47,11 @@ getRechargeR uId = do
Just user -> do Just user -> do
(rechargeWidget, enctype) <- generateFormPost rechargeForm (rechargeWidget, enctype) <- generateFormPost rechargeForm
currency <- appCurrency <$> appSettings <$> getYesod currency <- appCurrency <$> appSettings <$> getYesod
defaultLayout $ do defaultLayout $
$(widgetFile "recharge") $(widgetFile "recharge")
Nothing -> do Nothing -> do
setMessageI MsgUserUnknown setMessageI MsgUserUnknown
redirect $ HomeR redirect HomeR
postRechargeR :: UserId -> Handler Html postRechargeR :: UserId -> Handler Html
postRechargeR uId = do postRechargeR uId = do
@ -60,24 +60,24 @@ postRechargeR uId = do
Just user -> do Just user -> do
((res, _), _) <- runFormPost rechargeForm ((res, _), _) <- runFormPost rechargeForm
case res of case res of
FormSuccess amount -> do FormSuccess amount ->
case amount < 0 of if amount < 0
False -> do then do
updateCashier amount ("Guthaben: " `T.append` (userIdent user))
time <- liftIO getCurrentTime
secs <- return $ R.read $ formatTime defaultTimeLocale "%s" time
runDB $ update uId [UserBalance +=. amount, UserTimestamp =. secs]
setMessageI MsgRecharged
redirect $ HomeR
True -> do
setMessageI MsgNegativeRecharge setMessageI MsgNegativeRecharge
redirect $ RechargeR uId redirect $ RechargeR uId
else do
updateCashier amount ("Guthaben: " `T.append` userIdent user)
time <- liftIO getCurrentTime
let secs = R.read $ formatTime defaultTimeLocale "%s" time
runDB $ update uId [UserBalance +=. amount, UserTimestamp =. secs]
setMessageI MsgRecharged
redirect HomeR
_ -> do _ -> do
setMessageI MsgRechargeError setMessageI MsgRechargeError
redirect $ HomeR redirect HomeR
Nothing -> do Nothing -> do
setMessageI MsgUserUnknown setMessageI MsgUserUnknown
redirect $ HomeR redirect HomeR
rechargeForm :: Form Int rechargeForm :: Form Int
rechargeForm = renderDivs rechargeForm = renderDivs

View file

@ -25,7 +25,7 @@ getSummaryR :: Handler Html
getSummaryR = do getSummaryR = do
master <- getYesod master <- getYesod
bevs <- runDB $ selectList [] [Asc BeverageIdent] bevs <- runDB $ selectList [] [Asc BeverageIdent]
defaultLayout $ do defaultLayout $
$(widgetFile "summary") $(widgetFile "summary")
getSummaryJsonR :: Handler RepJson getSummaryJsonR :: Handler RepJson
@ -37,8 +37,8 @@ getSummaryJsonR = do
map (\(Entity _ bev) -> map (\(Entity _ bev) ->
object [ "name" .= beverageIdent bev object [ "name" .= beverageIdent bev
, "value" .= beverageAmount bev , "value" .= beverageAmount bev
, "volume" .= ((fromIntegral (beverageMl bev)) / 1000 :: Double) , "volume" .= (fromIntegral (beverageMl bev) / 1000 :: Double)
, "price" .= ((fromIntegral (beveragePrice bev)) / 100 :: Double) , "price" .= (fromIntegral (beveragePrice bev) / 100 :: Double)
, "currency" .= appCurrency (appSettings master) , "currency" .= appCurrency (appSettings master)
] ]
) bevs ) bevs
@ -87,27 +87,27 @@ getInventoryJsonR = do
getUploadInventoryJsonR :: Handler Html getUploadInventoryJsonR :: Handler Html
getUploadInventoryJsonR = do getUploadInventoryJsonR = do
(uploadJsonWidget, enctype) <- generateFormPost uploadJsonForm (uploadJsonWidget, enctype) <- generateFormPost uploadJsonForm
defaultLayout $ do defaultLayout $
$(widgetFile "uploadJson") $(widgetFile "uploadJson")
postUploadInventoryJsonR :: Handler Html postUploadInventoryJsonR :: Handler Html
postUploadInventoryJsonR = do postUploadInventoryJsonR = do
((res, _), _) <- runFormPost uploadJsonForm ((res, _), _) <- runFormPost uploadJsonForm
case res of case res of
FormSuccess file -> do FormSuccess file ->
case fileContentType file == "application/json" of if fileContentType file == "application/json"
True -> do then do
source <- runResourceT $ fileSource file $$ sinkLbs source <- runResourceT $ fileSource file $$ sinkLbs
bevs <- return $ fromMaybe [] $ (decode source :: Maybe [BevStore]) let bevs = fromMaybe [] (decode source :: Maybe [BevStore])
I.mapM_ insOrUpd bevs I.mapM_ insOrUpd bevs
setMessageI MsgRestoreSuccess setMessageI MsgRestoreSuccess
redirect $ HomeR redirect HomeR
False -> do else do
setMessageI MsgNotJson setMessageI MsgNotJson
redirect $ UploadInventoryJsonR redirect UploadInventoryJsonR
_ -> do _ -> do
setMessageI MsgErrorOccured setMessageI MsgErrorOccured
redirect $ UploadInventoryJsonR redirect UploadInventoryJsonR
uploadJsonForm :: Form FileInfo uploadJsonForm :: Form FileInfo
uploadJsonForm = renderDivs uploadJsonForm = renderDivs
@ -117,14 +117,14 @@ insOrUpd :: BevStore -> Handler ()
insOrUpd bev = do insOrUpd bev = do
meb <- runDB $ getBy $ UniqueBeverage $ bevStoreIdent bev meb <- runDB $ getBy $ UniqueBeverage $ bevStoreIdent bev
case meb of case meb of
Just eb -> do Just eb ->
runDB $ update (entityKey eb) runDB $ update (entityKey eb)
[ BeveragePrice =. bevStorePrice bev [ BeveragePrice =. bevStorePrice bev
, BeverageAmount =. bevStoreAmount bev , BeverageAmount =. bevStoreAmount bev
, BeverageAlertAmount =. bevStoreAlertAmount bev , BeverageAlertAmount =. bevStoreAlertAmount bev
, BeverageMl =. bevStoreMl bev , BeverageMl =. bevStoreMl bev
] ]
Nothing -> do Nothing ->
runDB $ insert_ $ Beverage runDB $ insert_ $ Beverage
(bevStoreIdent bev) (bevStoreIdent bev)
(bevStorePrice bev) (bevStorePrice bev)

View file

@ -24,9 +24,9 @@ getTransferSelectR :: UserId -> Handler Html
getTransferSelectR from = do getTransferSelectR from = do
mUser <- runDB $ get from mUser <- runDB $ get from
case mUser of case mUser of
Just user -> do Just _ -> do
users <- runDB $ selectList [UserId !=. from] [Asc UserIdent] users <- runDB $ selectList [UserId !=. from] [Asc UserIdent]
defaultLayout $ do defaultLayout $
$(widgetFile "transferSelect") $(widgetFile "transferSelect")
Nothing -> do Nothing -> do
setMessageI MsgUserUnknown setMessageI MsgUserUnknown
@ -62,17 +62,17 @@ postTransferR from to = do
((res, _), _) <- runFormPost transferForm ((res, _), _) <- runFormPost transferForm
case res of case res of
FormSuccess amount -> do FormSuccess amount -> do
case amount < 0 of if amount < 0
False -> do then do
setMessageI MsgNegativeTransfer
redirect $ TransferR from to
else do
runDB $ update from [UserBalance -=. amount] runDB $ update from [UserBalance -=. amount]
runDB $ update to [UserBalance +=. amount] runDB $ update to [UserBalance +=. amount]
master <- getYesod master <- getYesod
liftIO $ notify sender recpt amount master liftIO $ notify sender recpt amount master
setMessageI MsgTransferComplete setMessageI MsgTransferComplete
redirect HomeR redirect HomeR
True -> do
setMessageI MsgNegativeTransfer
redirect $ TransferR from to
_ -> do _ -> do
setMessageI MsgTransferError setMessageI MsgTransferError
redirect HomeR redirect HomeR

View file

@ -3,7 +3,7 @@
/favicon.ico FaviconR GET /favicon.ico FaviconR GET
/robots.txt RobotsR GET /robots.txt RobotsR GET
/ HomeR GET POST / HomeR GET
/reactivate ReactivateR GET /reactivate ReactivateR GET
/user/#UserId/reactivate UserReactivateR GET /user/#UserId/reactivate UserReactivateR GET
/user/#UserId SelectR GET /user/#UserId SelectR GET