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 (void)
import Control.Monad.Reader (asks, ask) import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM (readTVarIO) import Control.Concurrent.STM (readTVarIO)
@ -19,21 +19,21 @@ authGet
:: TicketRequest :: TicketRequest
-> MateHandler AuthInfo -> MateHandler AuthInfo
authGet (TicketRequest uid method) = authGet (TicketRequest uid method) =
getUserAuthInfo uid method =<< (asks rsConnection) getUserAuthInfo uid method =<< asks rsConnection
authSend authSend
:: AuthRequest :: AuthRequest
-> MateHandler AuthResult -> MateHandler AuthResult
authSend req = uncurry (processAuthRequest req) =<< ((,) <$> authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
(liftIO . readTVarIO =<< rsTicketStore <$> ask) <*> (liftIO . readTVarIO =<< asks rsTicketStore) <*>
(asks rsConnection) asks rsConnection
) )
authLogout authLogout
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> MateHandler () -> MateHandler ()
authLogout (Just (muid, _)) = authLogout (Just (muid, _)) =
processLogout muid =<< (asks rsConnection) processLogout muid =<< asks rsConnection
authLogout Nothing = authLogout Nothing =
throwError $ err401 throwError $ err401
{ errBody = "Unauthorized access" { errBody = "Unauthorized access"
@ -43,7 +43,7 @@ authManageList
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> MateHandler [AuthOverview] -> MateHandler [AuthOverview]
authManageList (Just (uid, method)) = authManageList (Just (uid, method)) =
if elem method [PrimaryPass, ChallengeResponse] if method `elem` [PrimaryPass, ChallengeResponse]
then do then do
conn <- asks rsConnection conn <- asks rsConnection
selectAuthOverviews uid conn selectAuthOverviews uid conn
@ -61,7 +61,7 @@ authManageNewAuth
-> AuthSubmit -> AuthSubmit
-> MateHandler Int -> MateHandler Int
authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) = authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) =
if elem method [PrimaryPass, ChallengeResponse] if method `elem` [PrimaryPass, ChallengeResponse]
then do then do
conn <- asks rsConnection conn <- asks rsConnection
putUserAuthInfo uid asmethod ascomment aspayload conn putUserAuthInfo uid asmethod ascomment aspayload conn
@ -79,7 +79,7 @@ authManageDeleteAuth
-> Int -> Int
-> MateHandler () -> MateHandler ()
authManageDeleteAuth (Just (uid, method)) adid = authManageDeleteAuth (Just (uid, method)) adid =
if elem method [PrimaryPass, ChallengeResponse] if method `elem` [PrimaryPass, ChallengeResponse]
then do then do
conn <- asks rsConnection conn <- asks rsConnection
ads <- selectAuthOverviews uid conn ads <- selectAuthOverviews uid conn

View file

@ -1,4 +1,3 @@
{-# LANGUAGE OverloadedStrings #-}
module Control.Buy where module Control.Buy where
import Control.Monad (void, foldM) import Control.Monad (void, foldM)
@ -14,7 +13,7 @@ buy
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> [PurchaseDetail] -> [PurchaseDetail]
-> MateHandler PurchaseResult -> MateHandler PurchaseResult
buy (Just (auid, _)) pds = do buy auth pds = do
conn <- asks rsConnection conn <- asks rsConnection
(missing, real) <- foldM (\(ms, rs) pd -> do (missing, real) <- foldM (\(ms, rs) pd -> do
mmiss <- checkProductAvailability pd conn mmiss <- checkProductAvailability pd conn
@ -37,40 +36,17 @@ buy (Just (auid, _)) pds = do
) )
0 0
real real
void $ addToUserBalance auid (-price) conn case auth of
newBalance <- userBalanceSelect conn auid Just (auid, _) -> do
return $ PurchaseResult void $ addToUserBalance auid (-price) conn
( if newBalance < 0 newBalance <- userBalanceSelect conn auid
then PurchaseDebtful return $ PurchaseResult
else PurchaseOK ( if newBalance < 0
) then PurchaseDebtful
missing else PurchaseOK
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 missing
( ms Nothing ->
, pd:rs return $ PurchaseResult
) (PayAmount price)
) missing
([], [])
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

View file

@ -50,7 +50,7 @@ userUpdate Nothing _ =
{ errBody = "No Authentication present." { errBody = "No Authentication present."
} }
userUpdate (Just (aid, method)) uds = userUpdate (Just (aid, method)) uds =
if elem method [PrimaryPass, ChallengeResponse] if method `elem` [PrimaryPass, ChallengeResponse]
then do then do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
conn <- asks rsConnection conn <- asks rsConnection
@ -102,7 +102,7 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) =
then then
if auid /= target if auid /= target
then then
if elem method [PrimaryPass, ChallengeResponse] if method `elem` [PrimaryPass, ChallengeResponse]
then do then do
conn <- asks rsConnection conn <- asks rsConnection
user <- userDetailsSelect auid conn user <- userDetailsSelect auid conn

View file

@ -10,7 +10,7 @@ import Control.Arrow
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask) import Control.Monad.Reader (asks)
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.STM import Control.Concurrent.STM
@ -283,8 +283,8 @@ generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
else else
return Denied return Denied
where where
validatePass provided = validatePass =
any (provided ==) elem
validateChallengeResponse _ _ = validateChallengeResponse _ _ =
error "Validation of challenge response authentication not yet implemented" 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 :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket)
newTicket ident method = do newTicket ident method = do
store <- rsTicketStore <$> ask store <- asks rsTicketStore
rand1 <- liftIO generateRandomText rand1 <- liftIO generateRandomText
rand2 <- liftIO $ case method of rand2 <- liftIO $ case method of
ChallengeResponse -> Just <$> generateRandomText ChallengeResponse -> Just <$> generateRandomText

View file

@ -128,43 +128,44 @@ productOverviewSelect refine conn = do
) )
] ]
mapM mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> do (generateProductOverview conn)
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
)
prods 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 productOverviewSelectSingle
:: Int :: Int
@ -189,41 +190,7 @@ productOverviewSelectSingle pid conn = do
) )
] ]
head <$> mapM head <$> mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> do (generateProductOverview conn)
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
)
prods prods
@ -259,20 +226,7 @@ productShortOverviewSelect refine conn = do
] ]
mapM mapM
(\(i1, i2, i3, i4, _, _, _, _, _) -> do (\(i1, i2, i3, i4, _, _, _, _, _) -> do
amounts <- liftIO $ runSelect conn amounts <- liftIO $ queryAmounts conn i1
( 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 (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
return $ ProductShortOverview return $ ProductShortOverview
i1 i2 ii3 ii4 i3 i4 i1 i2 ii3 ii4 i3 i4

View file

@ -7,8 +7,6 @@ import Data.Time.Clock
import Data.Profunctor.Product (p6) import Data.Profunctor.Product (p6)
import Data.ByteString hiding (head, foldl)
import Data.Int (Int64) import Data.Int (Int64)
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
@ -24,7 +22,6 @@ import qualified Opaleye.Constant as C
import Types.User import Types.User
import Types.Refine import Types.Refine
import Types.Auth
import Types.Reader import Types.Reader
initUser :: PGS.Query initUser :: PGS.Query
@ -70,7 +67,7 @@ userSelect
-> PGS.Connection -> PGS.Connection
-> MateHandler [UserSummary] -> MateHandler [UserSummary]
userSelect ref conn = do userSelect ref conn = do
today <- utctDay <$> (liftIO getCurrentTime) today <- utctDay <$> liftIO getCurrentTime
users <- liftIO $ runSelect conn (case ref of users <- liftIO $ runSelect conn (case ref of
AllUsers -> selectTable userTable AllUsers -> selectTable userTable
ActiveUsers -> keepWhen (\(_, _, _, ts, _, _) -> ActiveUsers -> keepWhen (\(_, _, _, ts, _, _) ->
@ -89,7 +86,7 @@ userSelect ref conn = do
) )
] ]
mapM mapM
(\(i1, i2, i3, i4, i5, i6) -> return $ (\(i1, i2, _, _, _, i6) -> return $
UserSummary i1 i2 i6 UserSummary i1 i2 i6
) )
users users