linted
This commit is contained in:
parent
2d627e91e8
commit
35ae7833c5
16 changed files with 203 additions and 210 deletions
|
@ -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"
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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")
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue