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