c3d2/yammat
c3d2
/
yammat
38
0
Fork 1
Code Issues Pull Requests Releases Activity

linted

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
Foundation.hs
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"

45
Handler/Avatar.hs
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

26
Handler/Barcode.hs
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

46
Handler/Buy.hs
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

6
Handler/CashCheck.hs
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

51
Handler/Common.hs
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)

18
Handler/Home.hs
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

32
Handler/Journal.hs
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")

22
Handler/Modify.hs
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

22
Handler/NewUser.hs
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

6
Handler/Payout.hs
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

28
Handler/Restock.hs
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

34
Handler/Select.hs
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

28
Handler/Summary.hs
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)

14
Handler/Transfer.hs
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

2
config/routes
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