advanced linting

This commit is contained in:
nek0 2019-10-14 23:34:45 +02:00
parent 4000e42110
commit 9165e81fe2
6 changed files with 68 additions and 141 deletions

View file

@ -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

View file

@ -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,6 +36,8 @@ buy (Just (auid, _)) pds = do
)
0
real
case auth of
Just (auid, _) -> do
void $ addToUserBalance auid (-price) conn
newBalance <- userBalanceSelect conn auid
return $ PurchaseResult
@ -45,32 +46,7 @@ buy (Just (auid, _)) pds = do
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
)
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
Nothing ->
return $ PurchaseResult
(PayAmount price)
missing

View file

@ -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

View file

@ -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

View file

@ -128,21 +128,25 @@ productOverviewSelect refine conn = do
)
]
mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> do
amounts <- liftIO $ runSelect conn
( proc () -> do
(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 i1 .== a1
restrict -< C.constant pid .== a1
returnA -< stuff
) :: MateHandler
[ ( Int
, UTCTime
, Int
, Int
, Bool
)
]
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
@ -162,9 +166,6 @@ productOverviewSelect refine conn = do
(Prelude.reverse amounts)
return $ ProductOverview
i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9
)
prods
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

View file

@ -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