From 9165e81fe2d4611763125a6e3d9a4b0fbd6dc649 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 14 Oct 2019 23:34:45 +0200 Subject: [PATCH] advanced linting --- src/Control/Auth.hs | 16 +++--- src/Control/Buy.hs | 52 +++++------------- src/Control/User.hs | 4 +- src/Model/Auth.hs | 8 +-- src/Model/Product.hs | 122 ++++++++++++++----------------------------- src/Model/User.hs | 7 +-- 6 files changed, 68 insertions(+), 141 deletions(-) diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index cc75387..32978e5 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -5,7 +5,7 @@ import Servant import Control.Monad (void) -import Control.Monad.Reader (asks, ask) +import Control.Monad.Reader (asks) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.STM (readTVarIO) @@ -19,21 +19,21 @@ authGet :: TicketRequest -> MateHandler AuthInfo authGet (TicketRequest uid method) = - getUserAuthInfo uid method =<< (asks rsConnection) + getUserAuthInfo uid method =<< asks rsConnection authSend :: AuthRequest -> MateHandler AuthResult authSend req = uncurry (processAuthRequest req) =<< ((,) <$> - (liftIO . readTVarIO =<< rsTicketStore <$> ask) <*> - (asks rsConnection) + (liftIO . readTVarIO =<< asks rsTicketStore) <*> + asks rsConnection ) authLogout :: Maybe (Int, AuthMethod) -> MateHandler () authLogout (Just (muid, _)) = - processLogout muid =<< (asks rsConnection) + processLogout muid =<< asks rsConnection authLogout Nothing = throwError $ err401 { errBody = "Unauthorized access" @@ -43,7 +43,7 @@ authManageList :: Maybe (Int, AuthMethod) -> MateHandler [AuthOverview] authManageList (Just (uid, method)) = - if elem method [PrimaryPass, ChallengeResponse] + if method `elem` [PrimaryPass, ChallengeResponse] then do conn <- asks rsConnection selectAuthOverviews uid conn @@ -61,7 +61,7 @@ authManageNewAuth -> AuthSubmit -> MateHandler Int authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) = - if elem method [PrimaryPass, ChallengeResponse] + if method `elem` [PrimaryPass, ChallengeResponse] then do conn <- asks rsConnection putUserAuthInfo uid asmethod ascomment aspayload conn @@ -79,7 +79,7 @@ authManageDeleteAuth -> Int -> MateHandler () authManageDeleteAuth (Just (uid, method)) adid = - if elem method [PrimaryPass, ChallengeResponse] + if method `elem` [PrimaryPass, ChallengeResponse] then do conn <- asks rsConnection ads <- selectAuthOverviews uid conn diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs index 44b7ddb..e0bdac7 100644 --- a/src/Control/Buy.hs +++ b/src/Control/Buy.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} module Control.Buy where import Control.Monad (void, foldM) @@ -14,7 +13,7 @@ buy :: Maybe (Int, AuthMethod) -> [PurchaseDetail] -> MateHandler PurchaseResult -buy (Just (auid, _)) pds = do +buy auth pds = do conn <- asks rsConnection (missing, real) <- foldM (\(ms, rs) pd -> do mmiss <- checkProductAvailability pd conn @@ -37,40 +36,17 @@ buy (Just (auid, _)) pds = do ) 0 real - void $ addToUserBalance auid (-price) conn - newBalance <- userBalanceSelect conn auid - return $ PurchaseResult - ( if newBalance < 0 - then PurchaseDebtful - else PurchaseOK - ) - missing -buy Nothing pds = do - conn <- asks rsConnection - (missing, real) <- foldM (\(ms, rs) pd -> do - mmiss <- checkProductAvailability pd conn - case mmiss of - Just miss -> return - ( (pd {purchaseDetailAmount = miss}):ms - , pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs + case auth of + Just (auid, _) -> do + void $ addToUserBalance auid (-price) conn + newBalance <- userBalanceSelect conn auid + return $ PurchaseResult + ( if newBalance < 0 + then PurchaseDebtful + else PurchaseOK ) - Nothing -> return - ( ms - , pd:rs - ) - ) - ([], []) - pds - mapM_ - (`postBuyProductAmountUpdate` conn) - real - price <- foldM - (\total pd -> - fmap (+ total) (getLatestTotalPrice pd conn) - ) - 0 - real - void $ insertNewJournalEntry (JournalSubmit "Cash purchase" price) conn - return $ PurchaseResult - (PayAmount price) - missing + missing + Nothing -> + return $ PurchaseResult + (PayAmount price) + missing diff --git a/src/Control/User.hs b/src/Control/User.hs index c4dbda5..54957fd 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -50,7 +50,7 @@ userUpdate Nothing _ = { errBody = "No Authentication present." } userUpdate (Just (aid, method)) uds = - if elem method [PrimaryPass, ChallengeResponse] + if method `elem` [PrimaryPass, ChallengeResponse] then do now <- liftIO getCurrentTime conn <- asks rsConnection @@ -102,7 +102,7 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) = then if auid /= target then - if elem method [PrimaryPass, ChallengeResponse] + if method `elem` [PrimaryPass, ChallengeResponse] then do conn <- asks rsConnection user <- userDetailsSelect auid conn diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index d392f04..43e7e9f 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -10,7 +10,7 @@ import Control.Arrow import Control.Monad (void) import Control.Monad.IO.Class (liftIO) -import Control.Monad.Reader (ask) +import Control.Monad.Reader (asks) import Control.Concurrent (threadDelay) import Control.Concurrent.STM @@ -283,8 +283,8 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do else return Denied where - validatePass provided = - any (provided ==) + validatePass = + elem validateChallengeResponse _ _ = error "Validation of challenge response authentication not yet implemented" @@ -334,7 +334,7 @@ deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket) newTicket ident method = do - store <- rsTicketStore <$> ask + store <- asks rsTicketStore rand1 <- liftIO generateRandomText rand2 <- liftIO $ case method of ChallengeResponse -> Just <$> generateRandomText diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 02a63e5..fbcc499 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -128,43 +128,44 @@ productOverviewSelect refine conn = do ) ] mapM - (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> do - amounts <- liftIO $ runSelect conn - ( proc () -> do - stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts)) - (queryTable amountTable) -< () - restrict -< C.constant i1 .== a1 - returnA -< stuff - ) :: MateHandler - [ ( Int - , UTCTime - , Int - , Int - , Bool - ) - ] - (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts - let ii5 = snd $ - foldl - (\(bef, van) (_, _, amo, _, ver) -> - if ver - then (amo, if amo < bef then van + (bef - amo) else van) - else (amo, van) - ) - (0, 0) - (Prelude.reverse amounts) - ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) -> - if ver - then (amo, tot) - else (amo, tot + max 0 (bef - amo)) - ) - (0, 0) - (Prelude.reverse amounts) - return $ ProductOverview - i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9 - ) + (generateProductOverview conn) prods +queryAmounts + :: PGS.Connection + -> Int + -> IO [(Int, UTCTime, Int, Int, Bool)] +queryAmounts conn pid = runSelect conn $ proc () -> do + stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts)) + (queryTable amountTable) -< () + restrict -< C.constant pid .== a1 + returnA -< stuff + +generateProductOverview + :: PGS.Connection + -> (Int, Text, Int, Maybe Int, Maybe Int, Int, Int, Maybe Int, Maybe Text) + -> MateHandler ProductOverview +generateProductOverview conn (i1, i2, i3, i4, i5, i6, i7, i8, i9) = do + amounts <- liftIO $ queryAmounts conn i1 + (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts + let ii5 = snd $ + foldl + (\(bef, van) (_, _, amo, _, ver) -> + if ver + then (amo, if amo < bef then van + (bef - amo) else van) + else (amo, van) + ) + (0, 0) + (Prelude.reverse amounts) + ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) -> + if ver + then (amo, tot) + else (amo, tot + max 0 (bef - amo)) + ) + (0, 0) + (Prelude.reverse amounts) + return $ ProductOverview + i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9 productOverviewSelectSingle :: Int @@ -189,41 +190,7 @@ productOverviewSelectSingle pid conn = do ) ] head <$> mapM - (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> do - amounts <- liftIO $ runSelect conn - ( proc () -> do - stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts)) - (queryTable amountTable) -< () - restrict -< C.constant i1 .== a1 - returnA -< stuff - ) :: MateHandler - [ ( Int - , UTCTime - , Int - , Int - , Bool - ) - ] - (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts - let ii5 = snd $ - foldl - (\(bef, van) (_, _, amo, _, ver) -> - if ver - then (amo, if amo < bef then van + (bef - amo) else van) - else (amo, van) - ) - (0, 0) - (Prelude.reverse amounts) - ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) -> - if ver - then (amo, tot) - else (amo, tot + max 0 (bef - amo)) - ) - (0, 0) - (Prelude.reverse amounts) - return $ ProductOverview - i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9 - ) + (generateProductOverview conn) prods @@ -259,20 +226,7 @@ productShortOverviewSelect refine conn = do ] mapM (\(i1, i2, i3, i4, _, _, _, _, _) -> do - amounts <- liftIO $ runSelect conn - ( proc () -> do - stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts)) - (queryTable amountTable) -< () - restrict -< C.constant i1 .== a1 - returnA -< stuff - ) :: MateHandler - [ ( Int - , UTCTime - , Int - , Int - , Bool - ) - ] + amounts <- liftIO $ queryAmounts conn i1 (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts return $ ProductShortOverview i1 i2 ii3 ii4 i3 i4 diff --git a/src/Model/User.hs b/src/Model/User.hs index c158220..d8f7b1d 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -7,8 +7,6 @@ import Data.Time.Clock import Data.Profunctor.Product (p6) -import Data.ByteString hiding (head, foldl) - import Data.Int (Int64) import qualified Database.PostgreSQL.Simple as PGS @@ -24,7 +22,6 @@ import qualified Opaleye.Constant as C import Types.User import Types.Refine -import Types.Auth import Types.Reader initUser :: PGS.Query @@ -70,7 +67,7 @@ userSelect -> PGS.Connection -> MateHandler [UserSummary] userSelect ref conn = do - today <- utctDay <$> (liftIO getCurrentTime) + today <- utctDay <$> liftIO getCurrentTime users <- liftIO $ runSelect conn (case ref of AllUsers -> selectTable userTable ActiveUsers -> keepWhen (\(_, _, _, ts, _, _) -> @@ -89,7 +86,7 @@ userSelect ref conn = do ) ] mapM - (\(i1, i2, i3, i4, i5, i6) -> return $ + (\(i1, i2, _, _, _, i6) -> return $ UserSummary i1 i2 i6 ) users