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 t0 = if T.null t1
then t1
else if T.head t1 == '.'
then '0' `T.cons` t1
else if "-." `T.isPrefixOf` t1
then "-0." `T.append` (T.drop 2 t1)
else t1
where t1 = T.dropWhile ((==) ' ') t0
prependZero t0
| T.null t1 = t1
| T.head t1 == '.' = '0' `T.cons` t1
| "-." `T.isPrefixOf` t1 = "-0." `T.append` T.drop 2 t1
| otherwise = t1
where t1 = T.dropWhile (' ' ==) t0
formatFloat :: Double -> Text
formatFloat d = T.pack (pre ++ t ++ c)
where
t = reverse (intercalate "." $ chunksOf 3 $ reverse $ fst sp)
c = "," ++ tail (snd sp)
sp = (break (== '.') (printf "%.2f" (abs d)))
pre = case d < 0 of
True -> "-"
False -> ""
sp = break (== '.') (printf "%.2f" (abs d))
pre = if d < 0
then "-"
else ""
-- T.pack . (splitEvery 3) . (printf "%,2f")
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
-- keep settings and values requiring initialization before your application
@ -97,9 +94,9 @@ approotRequest master req =
Nothing -> appRoot $ appSettings master
where
prefix =
case isSecure req of
True -> "https://"
False -> "http://"
if isSecure req
then "https://"
else "http://"
-- Please see the documentation for the Yesod typeclass. There are a number
-- 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,
-- default session idle timeout is 120 minutes
makeSessionBackend _ = fmap Just $ defaultClientSessionBackend
makeSessionBackend _ = Just <$> defaultClientSessionBackend
120 -- timeout in minutes
"config/client_session_key.aes"

View file

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

View file

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

View file

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

View file

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

View file

@ -33,22 +33,22 @@ import Import
getFaviconR :: Handler TypedContent
getFaviconR = return $ TypedContent "image/x-icon"
$ toContent $(embedFile "config/favicon.ico")
$ toContent $(embedFile "config/favicon.ico")
getRobotsR :: Handler TypedContent
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
| x == y = removeItem x ys
| otherwise = y : (removeItem x ys)
updateCashier :: Int -> Text -> Handler ()
updateCashier amount desc = do
mCashier <- runDB $ selectFirst [] [Desc CashierId]
trans <- liftIO $ (\time -> return $ Transaction desc amount time) =<< getCurrentTime
trans <- liftIO $ (return . Transaction desc amount) =<< getCurrentTime
case mCashier of
Just entCash -> do
runDB $ update (entityKey entCash) [CashierBalance +=. amount]
@ -62,9 +62,9 @@ getCashierBalance :: Handler Int
getCashierBalance = do
mCashier <- runDB $ selectFirst [] [Desc CashierId]
case mCashier of
Just cashier -> do
Just cashier ->
return $ cashierBalance $ entityVal cashier
Nothing -> do
Nothing ->
return 0
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 (Left uId) nbs = do
raws <- runDB $ selectList [BarcodeUser ==. Just uId] []
obs <- return $ map (barcodeCode . entityVal) raws
toDel <- return $ obs L.\\ nbs
toAdd <- return $ nbs L.\\ obs
_ <- mapM (\b -> runDB $ insert_ $ Barcode
let obs = map (barcodeCode . entityVal) raws
let toDel = obs L.\\ nbs
let toAdd = nbs L.\\ obs
mapM_ (\b -> runDB $ insert_ $ Barcode
b
True
(Just uId)
@ -121,10 +121,10 @@ handleBarcodes (Left uId) nbs = do
mapM_ (runDB . delete . entityKey . fromJust) ents
handleBarcodes (Right bId) nbs = do
raws <- runDB $ selectList [BarcodeBev ==. Just bId] []
obs <- return $ map (barcodeCode . entityVal) raws
toDel <- return $ obs L.\\ nbs
toAdd <- return $ nbs L.\\ obs
_ <- mapM (\b -> runDB $ insert $ Barcode
let obs = map (barcodeCode . entityVal) raws
let toDel = obs L.\\ nbs
let toAdd = nbs L.\\ obs
mapM_ (\b -> runDB $ insert_ $ Barcode
b
False
Nothing
@ -138,11 +138,11 @@ handleGetParam Nothing _ =
return ()
handleGetParam (Just b) eub = do
f <- return $ T.filter C.isAlphaNum b
case (T.length f) > 0 && b /= ", " of
True -> do
if T.length f > 0 && b /= ", "
then do
e <- runDB $ getBy $ UniqueBarcode f
case e of
Nothing -> do
if isNothing e
then do
_ <- case eub of
Left uId -> do
-- should usernames containing, among other, spaces cause problems, replace b for f here
@ -151,9 +151,9 @@ handleGetParam (Just b) eub = do
-- and here
runDB $ insert_ $ Barcode b False Nothing (Just bId)
setMessageI MsgBarcodeAdded
Just _ ->
else
setMessageI MsgBarcodeDuplicate
False -> do
else
setMessageI MsgProvideBarcode
amountField :: (RenderMessage (HandlerSite m) FormMessage, Show a, Monad m, Integral a) => Field m a
@ -174,10 +174,10 @@ amountField = Field
checkAlert :: BeverageId -> Handler ()
checkAlert bId = do
bev <- runDB $ getJust bId
case beverageAmount bev < beverageAlertAmount bev of
True -> do
if beverageAmount bev < beverageAlertAmount bev
then do
master <- getYesod
to <- return $ appEmail $ appSettings master
let to = appEmail $ appSettings master
liftIO $ sendMail to "Niedriger Bestand"
[stext|
Hallo,
@ -189,7 +189,8 @@ Viele Grüße,
der Matemat
|]
False -> return () -- do nothing
else
return () -- do nothing
--sendMail :: MonadIO m => Text -> Text -> Text -> m ()
sendMail to subject body =
@ -211,4 +212,4 @@ sendMail to subject body =
}
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
beverages <- runDB $ selectList [BeverageAmount !=. 0] [Desc BeverageIdent]
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]
defaultLayout $ do
defaultLayout $
$(widgetFile "home")
postHomeR :: Handler Html
postHomeR = do
error "Not yet implemented"
getReactivateR :: Handler Html
getReactivateR = do
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]
defaultLayout $ do
defaultLayout $
$(widgetFile "reactivate")
getUserReactivateR :: UserId -> Handler Html
@ -53,10 +49,10 @@ getUserReactivateR uId = do
case mUser of
Just user -> do
time <- liftIO getCurrentTime
secs <- return $ R.read $ formatTime defaultTimeLocale "%s" time
let secs = R.read $ formatTime defaultTimeLocale "%s" time
runDB $ update uId [UserTimestamp =. secs]
setMessageI MsgUserReactivated
redirect $ HomeR
redirect HomeR
Nothing -> do
setMessageI MsgUserUnknown
redirect $ HomeR
redirect HomeR

View file

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

View file

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

View file

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

View file

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

View file

@ -21,7 +21,7 @@ import Handler.Common
getRestockR :: Handler Html
getRestockR = do
beverages <- runDB $ selectList [] [Asc BeverageIdent]
defaultLayout $ do
defaultLayout $
$(widgetFile "restock")
getUpstockR :: BeverageId -> Handler Html
@ -30,26 +30,26 @@ getUpstockR bId = do
case mBev of
Just bev -> do
(upstockWidget, enctype) <- generateFormPost upstockForm
defaultLayout $ do
defaultLayout $
$(widgetFile "upstock")
Nothing -> do
setMessageI MsgItemUnknown
redirect $ HomeR
redirect HomeR
postUpstockR :: BeverageId -> Handler Html
postUpstockR bId = do
mBev <- runDB $ get bId
case mBev of
Just bev -> do
Just _ -> do
((res, _), _) <- runFormPost upstockForm
case res of
FormSuccess c -> do
case c > 0 of
True -> do
FormSuccess c ->
if c > 0
then do
runDB $ update bId [BeverageAmount +=. c]
setMessageI MsgStockedUp
redirect $ HomeR
False -> do
redirect HomeR
else do
setMessageI MsgNotStockedUp
redirect $ UpstockR bId
_ -> do
@ -57,7 +57,7 @@ postUpstockR bId = do
redirect $ UpstockR bId
Nothing -> do
setMessageI MsgItemUnknown
redirect $ HomeR
redirect HomeR
upstockForm :: Form Int
upstockForm = renderDivs
@ -66,7 +66,7 @@ upstockForm = renderDivs
getNewArticleR :: Handler Html
getNewArticleR = do
(newArticleWidget, enctype) <- generateFormPost newArticleForm
defaultLayout $ do
defaultLayout $
$(widgetFile "newArticle")
postNewArticleR :: Handler Html
@ -76,10 +76,10 @@ postNewArticleR = do
FormSuccess bev -> do
runDB $ insert_ bev
setMessageI MsgItemAdded
redirect $ HomeR
redirect HomeR
_ -> do
setMessageI MsgItemNotAdded
redirect $ HomeR
redirect HomeR
newArticleForm :: Form Beverage
newArticleForm = renderDivs $ Beverage
@ -93,4 +93,4 @@ newArticleForm = renderDivs $ Beverage
where
avatars = do
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
master <- getYesod
beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent]
defaultLayout $ do
defaultLayout $
$(widgetFile "select")
Nothing -> do
setMessageI MsgUserUnknown
redirect $ HomeR
redirect HomeR
getSelectCashR :: Handler Html
getSelectCashR = do
beverages <- runDB $ selectList [BeverageAmount >. 0] [Asc BeverageIdent]
defaultLayout $ do
defaultLayout $
$(widgetFile "selectCash")
getRechargeR :: UserId -> Handler Html
@ -47,11 +47,11 @@ getRechargeR uId = do
Just user -> do
(rechargeWidget, enctype) <- generateFormPost rechargeForm
currency <- appCurrency <$> appSettings <$> getYesod
defaultLayout $ do
defaultLayout $
$(widgetFile "recharge")
Nothing -> do
setMessageI MsgUserUnknown
redirect $ HomeR
redirect HomeR
postRechargeR :: UserId -> Handler Html
postRechargeR uId = do
@ -60,24 +60,24 @@ postRechargeR uId = do
Just user -> do
((res, _), _) <- runFormPost rechargeForm
case res of
FormSuccess amount -> do
case amount < 0 of
False -> 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
FormSuccess amount ->
if amount < 0
then do
setMessageI MsgNegativeRecharge
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
setMessageI MsgRechargeError
redirect $ HomeR
redirect HomeR
Nothing -> do
setMessageI MsgUserUnknown
redirect $ HomeR
redirect HomeR
rechargeForm :: Form Int
rechargeForm = renderDivs

View file

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

View file

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

View file

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