diff --git a/Foundation.hs b/Foundation.hs index be546f2..592b478 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -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" diff --git a/Handler/Avatar.hs b/Handler/Avatar.hs index c4427f0..d4b507d 100644 --- a/Handler/Avatar.hs +++ b/Handler/Avatar.hs @@ -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 diff --git a/Handler/Barcode.hs b/Handler/Barcode.hs index 8a44ac2..0bcc18a 100644 --- a/Handler/Barcode.hs +++ b/Handler/Barcode.hs @@ -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 diff --git a/Handler/Buy.hs b/Handler/Buy.hs index 52f99f2..4df18b1 100644 --- a/Handler/Buy.hs +++ b/Handler/Buy.hs @@ -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 diff --git a/Handler/CashCheck.hs b/Handler/CashCheck.hs index 48668f4..bb99550 100644 --- a/Handler/CashCheck.hs +++ b/Handler/CashCheck.hs @@ -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 diff --git a/Handler/Common.hs b/Handler/Common.hs index fd48a32..cc48097 100644 --- a/Handler/Common.hs +++ b/Handler/Common.hs @@ -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) diff --git a/Handler/Home.hs b/Handler/Home.hs index aa149aa..c936a27 100644 --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -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 diff --git a/Handler/Journal.hs b/Handler/Journal.hs index 299facb..3f37efb 100644 --- a/Handler/Journal.hs +++ b/Handler/Journal.hs @@ -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") diff --git a/Handler/Modify.hs b/Handler/Modify.hs index 6f286b5..2a714e7 100644 --- a/Handler/Modify.hs +++ b/Handler/Modify.hs @@ -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 diff --git a/Handler/NewUser.hs b/Handler/NewUser.hs index 89a7e01..41b8b6a 100644 --- a/Handler/NewUser.hs +++ b/Handler/NewUser.hs @@ -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 diff --git a/Handler/Payout.hs b/Handler/Payout.hs index 155af1c..8cc043a 100644 --- a/Handler/Payout.hs +++ b/Handler/Payout.hs @@ -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 diff --git a/Handler/Restock.hs b/Handler/Restock.hs index 65502f5..4ad920f 100644 --- a/Handler/Restock.hs +++ b/Handler/Restock.hs @@ -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 diff --git a/Handler/Select.hs b/Handler/Select.hs index b8ae367..c124c14 100644 --- a/Handler/Select.hs +++ b/Handler/Select.hs @@ -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 diff --git a/Handler/Summary.hs b/Handler/Summary.hs index acaea9a..cb01620 100644 --- a/Handler/Summary.hs +++ b/Handler/Summary.hs @@ -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) diff --git a/Handler/Transfer.hs b/Handler/Transfer.hs index 2332a35..c1d0716 100644 --- a/Handler/Transfer.hs +++ b/Handler/Transfer.hs @@ -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 diff --git a/config/routes b/config/routes index d18ce50..78eaddf 100644 --- a/config/routes +++ b/config/routes @@ -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