From 4000e42110a68e04934bac4b1fa3bff0446c9a94 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 14 Oct 2019 22:50:42 +0200 Subject: [PATCH] linted and hunted down warnings --- app/Main.hs | 5 ++- src/API.hs | 82 ++++++++++++++++++++++++++++-------------- src/Control/Auth.hs | 32 ++++++++--------- src/Control/Avatar.hs | 12 +++---- src/Control/Buy.hs | 16 ++++----- src/Control/Journal.hs | 4 +-- src/Control/Product.hs | 20 +++++------ src/Control/User.hs | 22 ++++++------ src/Model/Amount.hs | 12 +++---- src/Model/Auth.hs | 47 ++++++++++++------------ src/Model/Avatar.hs | 2 +- src/Model/Journal.hs | 3 +- src/Model/Product.hs | 60 +++++++++++++++---------------- src/Model/User.hs | 10 +++--- src/Types/Auth.hs | 1 - src/Types/Journal.hs | 2 +- src/Types/User.hs | 3 +- 17 files changed, 179 insertions(+), 154 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index fdf15a2..3c17e60 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -107,9 +107,8 @@ authHandler conn = mkAuthHandler handler handler :: Request -> Handler (Maybe (Int, AuthMethod)) handler req = do let headers = requestHeaders req - res <- case lookup "Authentication" headers of - Just hh -> do + case lookup "Authentication" headers of + Just hh -> validateToken hh conn _ -> return Nothing - return res diff --git a/src/API.hs b/src/API.hs index 2599e42..385c47e 100644 --- a/src/API.hs +++ b/src/API.hs @@ -1,10 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -68,34 +65,65 @@ type MateAPI = :<|> "avatar" :> "list" :> Get '[JSON] [Avatar] -( authGetLink :<|> - authSendLink :<|> - authLogoutLink :<|> +authGetLink :: Link +authSendLink :: Link +authLogoutLink :: Link - authManageListLink :<|> - authManageNewAuthLink :<|> - authManageDeleteAuthLink :<|> +authManageListLink :: Link +authManageNewAuthLink :: Link +authManageDeleteAuthLink :: Link - userNewLink :<|> - userGetLink :<|> - userUpdateLink :<|> - userListLink :<|> - userRechargeLink :<|> - userTransferLink :<|> +userNewLink :: Link +userGetLink :: Link +userUpdateLink :: Link +userListLink :: Maybe UserRefine -> Link +userRechargeLink :: Link +userTransferLink :: Link - productNewLink :<|> - productOverviewLink :<|> - productStockRefillLink :<|> - productStockUpdateLink :<|> - productListLink :<|> - productShortListLink :<|> +productNewLink :: Link +productOverviewLink :: Int -> Link +productStockRefillLink :: Link +productStockUpdateLink :: Link +productListLink :: Maybe ProductRefine -> Link +productShortListLink :: Maybe ProductRefine -> Link - buyLink :<|> +buyLink :: Link - journalShowLink :<|> +journalShowLink :: Maybe Int -> Maybe Int -> Link - avatarGetLink :<|> - avaterInsertLink :<|> - avatarUpdateLink :<|> - avatarListLink +avatarGetLink :: Int -> Link +avaterInsertLink :: Link +avatarUpdateLink :: Int -> Link +avatarListLink :: Link + +( (authGetLink :: Link) :<|> + (authSendLink :: Link) :<|> + (authLogoutLink :: Link) :<|> + + (authManageListLink :: Link) :<|> + (authManageNewAuthLink :: Link) :<|> + (authManageDeleteAuthLink :: Link) :<|> + + (userNewLink :: Link) :<|> + (userGetLink :: Link) :<|> + (userUpdateLink :: Link) :<|> + (userListLink :: Maybe UserRefine -> Link) :<|> + (userRechargeLink :: Link) :<|> + (userTransferLink :: Link) :<|> + + (productNewLink :: Link) :<|> + (productOverviewLink :: Int -> Link) :<|> + (productStockRefillLink :: Link) :<|> + (productStockUpdateLink :: Link) :<|> + (productListLink :: Maybe ProductRefine -> Link) :<|> + (productShortListLink :: Maybe ProductRefine -> Link) :<|> + + (buyLink :: Link) :<|> + + (journalShowLink :: Maybe Int -> Maybe Int -> Link) :<|> + + (avatarGetLink :: Int -> Link) :<|> + (avaterInsertLink :: Link) :<|> + (avatarUpdateLink :: Int -> Link) :<|> + (avatarListLink :: Link) ) = allLinks (Proxy :: Proxy MateAPI) diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index 7302eb7..cc75387 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 (ask) +import Control.Monad.Reader (asks, ask) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.STM (readTVarIO) @@ -18,23 +18,23 @@ import Model authGet :: TicketRequest -> MateHandler AuthInfo -authGet (TicketRequest uid method) = do - getUserAuthInfo uid method =<< (rsConnection <$> ask) +authGet (TicketRequest uid method) = + getUserAuthInfo uid method =<< (asks rsConnection) authSend :: AuthRequest -> MateHandler AuthResult authSend req = uncurry (processAuthRequest req) =<< ((,) <$> (liftIO . readTVarIO =<< rsTicketStore <$> ask) <*> - (rsConnection <$> ask) + (asks rsConnection) ) authLogout :: Maybe (Int, AuthMethod) -> MateHandler () -authLogout (Just (muid, method)) = do - processLogout muid =<< (rsConnection <$> ask) -authLogout Nothing = do +authLogout (Just (muid, _)) = + processLogout muid =<< (asks rsConnection) +authLogout Nothing = throwError $ err401 { errBody = "Unauthorized access" } @@ -43,9 +43,9 @@ authManageList :: Maybe (Int, AuthMethod) -> MateHandler [AuthOverview] authManageList (Just (uid, method)) = - if any (== method) [PrimaryPass, ChallengeResponse] + if elem method [PrimaryPass, ChallengeResponse] then do - conn <- rsConnection <$> ask + conn <- asks rsConnection selectAuthOverviews uid conn else throwError $ err401 @@ -60,10 +60,10 @@ authManageNewAuth :: Maybe (Int, AuthMethod) -> AuthSubmit -> MateHandler Int -authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) = do - if any (== method) [PrimaryPass, ChallengeResponse] +authManageNewAuth (Just (uid, method)) (AuthSubmit asmethod ascomment aspayload) = + if elem method [PrimaryPass, ChallengeResponse] then do - conn <- rsConnection <$> ask + conn <- asks rsConnection putUserAuthInfo uid asmethod ascomment aspayload conn else throwError $ err401 @@ -78,10 +78,10 @@ authManageDeleteAuth :: Maybe (Int, AuthMethod) -> Int -> MateHandler () -authManageDeleteAuth (Just (uid, method)) adid = do - if any (== method) [PrimaryPass, ChallengeResponse] +authManageDeleteAuth (Just (uid, method)) adid = + if elem method [PrimaryPass, ChallengeResponse] then do - conn <- rsConnection <$> ask + conn <- asks rsConnection ads <- selectAuthOverviews uid conn let currentad = head (filter (\ad -> authOverviewId ad == adid) ads) case authOverviewMethod currentad of @@ -107,7 +107,7 @@ authManageDeleteAuth (Just (uid, method)) adid = do throwError $ err406 { errBody = "You need at least one primary password or challenge response authentication" } -authManageDeleteAuth Nothing _ = do +authManageDeleteAuth Nothing _ = throwError $ err401 { errBody = "Unauthorized access" } diff --git a/src/Control/Avatar.hs b/src/Control/Avatar.hs index 2a1c49c..cddd244 100644 --- a/src/Control/Avatar.hs +++ b/src/Control/Avatar.hs @@ -3,7 +3,7 @@ module Control.Avatar where import Control.Monad (void) -import Control.Monad.Reader (ask) +import Control.Monad.Reader (asks) import Control.Monad.Trans (liftIO) @@ -26,7 +26,7 @@ avatarGet :: Int -> MateHandler Application avatarGet aid = do - conn <- rsConnection <$> ask + conn <- asks rsConnection as <- liftIO $ avatarSelectById aid conn if null as then @@ -47,7 +47,7 @@ avatarInsert -> AvatarData -> MateHandler Int avatarInsert (Just _) ad = do - conn <- rsConnection <$> ask + conn <- asks rsConnection insertAvatar ad conn avatarInsert Nothing _ = throwError $ err401 @@ -60,9 +60,9 @@ avatarUpdate -> AvatarData -> MateHandler () avatarUpdate (Just _) aid ad = do - conn <- rsConnection <$> ask + conn <- asks rsConnection void $ updateAvatar aid ad conn -avatarUpdate Nothing _ _ = do +avatarUpdate Nothing _ _ = throwError $ err401 { errBody = "No Authentication present." } @@ -70,5 +70,5 @@ avatarUpdate Nothing _ _ = do avatarList :: MateHandler [Avatar] avatarList = do - conn <- rsConnection <$> ask + conn <- asks rsConnection liftIO $ avatarSelect conn diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs index df5f30d..44b7ddb 100644 --- a/src/Control/Buy.hs +++ b/src/Control/Buy.hs @@ -3,7 +3,7 @@ module Control.Buy where import Control.Monad (void, foldM) -import Control.Monad.Reader (ask) +import Control.Monad.Reader (asks) -- internal imports @@ -15,13 +15,13 @@ buy -> [PurchaseDetail] -> MateHandler PurchaseResult buy (Just (auid, _)) pds = do - conn <- rsConnection <$> ask + 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) + , pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs ) Nothing -> return ( ms @@ -30,7 +30,7 @@ buy (Just (auid, _)) pds = do ) ([], []) pds - void $ mapM_ (\pd -> postBuyProductAmountUpdate pd conn) real + mapM_ (`postBuyProductAmountUpdate` conn) real price <- foldM (\total pd -> fmap (+ total) (getLatestTotalPrice pd conn) @@ -46,13 +46,13 @@ buy (Just (auid, _)) pds = do ) missing buy Nothing pds = do - conn <- rsConnection <$> ask + 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) + , pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs ) Nothing -> return ( ms @@ -61,8 +61,8 @@ buy Nothing pds = do ) ([], []) pds - void $ mapM_ - (\pd -> postBuyProductAmountUpdate pd conn) + mapM_ + (`postBuyProductAmountUpdate` conn) real price <- foldM (\total pd -> diff --git a/src/Control/Journal.hs b/src/Control/Journal.hs index 563a581..209cb36 100644 --- a/src/Control/Journal.hs +++ b/src/Control/Journal.hs @@ -3,7 +3,7 @@ module Control.Journal where import Servant -import Control.Monad.Reader (ask) +import Control.Monad.Reader (asks) -- internal imports @@ -16,7 +16,7 @@ journalShow -> Maybe Int -> MateHandler [JournalEntry] journalShow (Just _) mlimit moffset = do - conn <- rsConnection <$> ask + conn <- asks rsConnection selectJournalEntries mlimit moffset conn journalShow Nothing _ _ = throwError $ err401 diff --git a/src/Control/Product.hs b/src/Control/Product.hs index a2dcf0c..c467067 100644 --- a/src/Control/Product.hs +++ b/src/Control/Product.hs @@ -5,7 +5,7 @@ import Servant import Control.Monad (void) -import Control.Monad.Reader (ask) +import Control.Monad.Reader (asks) import Data.Maybe (fromMaybe) @@ -19,28 +19,28 @@ productNew -> ProductSubmit -> MateHandler Int productNew (Just _) bevsub = do - conn <- rsConnection <$> ask + conn <- asks rsConnection bevid <- insertProduct bevsub conn void $ insertNewEmptyAmount bevid bevsub conn return bevid productNew Nothing _ = - throwError $ err401 + throwError err401 productOverview :: Int -> MateHandler ProductOverview productOverview pid = do - conn <- rsConnection <$> ask + conn <- asks rsConnection productOverviewSelectSingle pid conn productStockRefill :: Maybe (Int, AuthMethod) -> [AmountRefill] -> MateHandler () -productStockRefill (Just _) amorefs = do +productStockRefill (Just _) amorefs = if all ((>= 0) . amountRefillAmount) amorefs then do - conn <- rsConnection <$> ask + conn <- asks rsConnection void $ manualProductAmountRefill amorefs conn else throwError $ err400 @@ -55,10 +55,10 @@ productStockUpdate :: Maybe (Int, AuthMethod) -> [AmountUpdate] -> MateHandler () -productStockUpdate (Just _) amoups = do +productStockUpdate (Just _) amoups = if all ((>= 0) . amountUpdateRealAmount) amoups then do - conn <- rsConnection <$> ask + conn <- asks rsConnection void $ manualProductAmountUpdate amoups conn else throwError $ err400 @@ -73,12 +73,12 @@ productList :: Maybe ProductRefine -> MateHandler [ProductOverview] productList mrefine = do - conn <- rsConnection <$> ask + conn <- asks rsConnection productOverviewSelect (fromMaybe AvailableProducts mrefine) conn productShortList :: Maybe ProductRefine -> MateHandler [ProductShortOverview] productShortList mrefine = do - conn <- rsConnection <$> ask + conn <- asks rsConnection productShortOverviewSelect (fromMaybe AvailableProducts mrefine) conn diff --git a/src/Control/User.hs b/src/Control/User.hs index 34b1be1..c4dbda5 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -5,7 +5,7 @@ import Servant import Control.Monad (void) -import Control.Monad.Reader (ask) +import Control.Monad.Reader (asks) import Control.Monad.IO.Class (liftIO) @@ -24,8 +24,8 @@ userNew :: UserSubmit -> MateHandler Int userNew (UserSubmit ident email passhash) = do - now <- liftIO $ getCurrentTime - conn <- rsConnection <$> ask + now <- liftIO getCurrentTime + conn <- asks rsConnection uid <- insertUser ident email (utctDay now) conn void $ putUserAuthInfo uid PrimaryPass "Initial password" passhash conn return uid @@ -38,7 +38,7 @@ userGet Nothing = { errBody = "No Authentication present." } userGet (Just (uid, _)) = do - conn <- rsConnection <$> ask + conn <- asks rsConnection userDetailsSelect uid conn userUpdate @@ -50,10 +50,10 @@ userUpdate Nothing _ = { errBody = "No Authentication present." } userUpdate (Just (aid, method)) uds = - if any (== method) [PrimaryPass, ChallengeResponse] + if elem method [PrimaryPass, ChallengeResponse] then do - now <- liftIO $ getCurrentTime - conn <- rsConnection <$> ask + now <- liftIO getCurrentTime + conn <- asks rsConnection void $ updateUserDetails aid uds (utctDay now) conn else throwError $ err401 @@ -64,7 +64,7 @@ userList :: Maybe UserRefine -> MateHandler [UserSummary] userList ref = do - conn <- rsConnection <$> ask + conn <- asks rsConnection userSelect (fromMaybe ActiveUsers ref) conn userRecharge @@ -74,7 +74,7 @@ userRecharge userRecharge (Just (auid, _)) (UserRecharge amount) = if amount >= 0 then do - conn <- rsConnection <$> ask + conn <- asks rsConnection ud <- userDetailsSelect auid conn void $ insertNewJournalEntry (JournalSubmit @@ -102,9 +102,9 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) = then if auid /= target then - if any (== method) [PrimaryPass, ChallengeResponse] + if elem method [PrimaryPass, ChallengeResponse] then do - conn <- rsConnection <$> ask + conn <- asks rsConnection user <- userDetailsSelect auid conn if amount < userDetailsBalance user then do diff --git a/src/Model/Amount.hs b/src/Model/Amount.hs index 0ce9556..0e00f8b 100644 --- a/src/Model/Amount.hs +++ b/src/Model/Amount.hs @@ -135,7 +135,7 @@ getLatestTotalPrice (PurchaseDetail pid amount) conn = do , Bool ) ] - (amount *) <$> head <$> return (map + (amount *) . head <$> return (map (\(_, _, _, price, _) -> price) amounts ) @@ -145,7 +145,7 @@ checkProductAvailability -> PGS.Connection -> MateHandler (Maybe Int) -- | Returns maybe missing amount checkProductAvailability (PurchaseDetail pid amount) conn = do - realamount <- (\(_, _, ramount, _, _) -> ramount) <$> head <$> + realamount <- (\(_, _, ramount, _, _) -> ramount) . head <$> (liftIO $ runSelect conn $ limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $ keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< @@ -172,7 +172,7 @@ manualProductAmountUpdate aups conn = mapM (\(AmountUpdate pid amount) -> do oldprice <- getLatestPriceByProductId pid conn - head <$> (liftIO $ do + head <$> liftIO (do now <- getCurrentTime runInsert_ conn $ Insert { iTable = amountTable @@ -202,7 +202,7 @@ manualProductAmountRefill aups conn = (\(AmountRefill pid amount) -> do oldamount <- getLatestAmountByProductId pid conn oldprice <- getLatestPriceByProductId pid conn - head <$> (liftIO $ do + head <$> liftIO (do now <- getCurrentTime runInsert_ conn $ Insert { iTable = amountTable @@ -228,8 +228,8 @@ postBuyProductAmountUpdate -> PGS.Connection -> MateHandler Int postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do - now <- liftIO $ getCurrentTime - (amount, oldprice) <- (\(_, _, am, op, _) -> (am, op)) <$> head <$> ( + now <- liftIO getCurrentTime + (amount, oldprice) <- (\(_, _, am, op, _) -> (am, op)) . head <$> ( liftIO $ runSelect conn $ limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $ keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index c924f71..d392f04 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Arrows #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -29,10 +28,9 @@ import qualified Data.Set as S import Data.Time.Clock -import Data.ByteString as B (ByteString, drop) +import Data.ByteString as B (ByteString) import Data.ByteString.Random import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Base16 as B16 import Opaleye hiding (null) import qualified Opaleye.Constant as C @@ -114,7 +112,7 @@ delayTime = 1 * 10 ^ (6 :: Int) generateRandomText :: IO T.Text -generateRandomText = decodeUtf8 <$> B64.encode <$> random 23 +generateRandomText = decodeUtf8 . B64.encode <$> random 23 selectAuthOverviews @@ -123,7 +121,7 @@ selectAuthOverviews -> MateHandler [AuthOverview] selectAuthOverviews uid conn = do authData <- liftIO $ runSelect conn (proc () -> do - (adid, aduid, admethod, adcomment, adpayload) <- + (adid, aduid, admethod, adcomment, _) <- queryTable authDataTable -< () restrict -< aduid .== C.constant uid returnA -< (adid, adcomment, admethod) @@ -147,8 +145,8 @@ getUserAuthInfo -> MateHandler AuthInfo getUserAuthInfo uid method conn = do authdata <- map (\(aid, auid, amethod, acomment, apayload) -> - (aid, auid, amethod, acomment, (decodeUtf8 $ B64.encode apayload))) <$> - (liftIO $ do + (aid, auid, amethod, acomment, decodeUtf8 $ B64.encode apayload)) <$> + liftIO (do void $ threadDelay delayTime runSelect conn (proc () -> do (aid, auid, amethod, acomment, apayload) <- @@ -207,7 +205,7 @@ deleteAuthDataById -> MateHandler Int64 deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete { dTable = authDataTable - , dWhere = (\(aid, _, _, _, _) -> aid .== C.constant adid) + , dWhere = \(aid, _, _, _, _) -> aid .== C.constant adid , dReturning = rCount } @@ -229,7 +227,7 @@ validateToken header conn = do ] case tokens of [(_, uid, stamp, method)] -> do - now <- liftIO $ getCurrentTime + now <- liftIO getCurrentTime if diffUTCTime stamp now > 0 then return $ Just (uid, toEnum method) else do @@ -250,7 +248,7 @@ generateToken -> AuthResponse -> PGS.Connection -> MateHandler AuthResult -generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do +generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do authData <- liftIO $ runSelect conn ( keepWhen (\(_, auid, amethod, _, _) -> auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method)) @@ -263,8 +261,11 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do , ByteString ) ] - let userPayloads = map (\(_, _, _, _, payload) -> - (decodeUtf8 payload)) authData + let userPayloads = map + (\(_, _, _, _, payload) -> + decodeUtf8 payload + ) + authData authResult = case method of PrimaryPass -> validatePass response userPayloads SecondaryPass -> validatePass response userPayloads @@ -282,9 +283,9 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do else return Denied where - validatePass provided presents = - any (\present -> provided == present) presents - validateChallengeResponse provided presents = + validatePass provided = + any (provided ==) + validateChallengeResponse _ _ = error "Validation of challenge response authentication not yet implemented" @@ -315,7 +316,7 @@ deleteToken deleteToken tstr conn = liftIO $ runDelete_ conn $ Delete { dTable = tokenTable - , dWhere = (\(rtstr, _, _, _) -> rtstr .== C.constant tstr) + , dWhere = \(rtstr, _, _, _) -> rtstr .== C.constant tstr , dReturning = rCount } @@ -326,7 +327,7 @@ deleteTokenByUserId -> MateHandler Int64 deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete { dTable = tokenTable - , dWhere = (\(_, rid, _, _) -> rid .== C.constant uid) + , dWhere = \(_, rid, _, _) -> rid .== C.constant uid , dReturning = rCount } @@ -334,18 +335,18 @@ deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete newTicket :: Int -> AuthMethod -> MateHandler (Maybe T.Text, AuthTicket) newTicket ident method = do store <- rsTicketStore <$> ask - rand1 <- liftIO $ generateRandomText + rand1 <- liftIO generateRandomText rand2 <- liftIO $ case method of ChallengeResponse -> Just <$> generateRandomText _ -> return Nothing - later <- liftIO $ (addUTCTime 23 <$> getCurrentTime) + later <- liftIO (addUTCTime 23 <$> getCurrentTime) let ticket = Ticket { ticketId = AuthTicket rand1 , ticketUser = ident , ticketExpiry = later , ticketMethod = (method, rand2) } - liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s) + liftIO $ atomically $ modifyTVar store (S.insert ticket) return (rand2, AuthTicket rand1) @@ -359,7 +360,7 @@ processAuthRequest (AuthRequest aticket hash) store conn = do case S.toList mticket of [ticket] -> do -- liftIO $ putStrLn "there is a ticket..." - now <- liftIO $ getCurrentTime + now <- liftIO getCurrentTime liftIO $ threadDelay delayTime if now > ticketExpiry ticket then @@ -374,7 +375,7 @@ processAuthRequest (AuthRequest aticket hash) store conn = do #else return Denied #endif - else do + else -- liftIO $ putStrLn "...and it is valid" generateToken ticket hash conn _ -> do @@ -395,5 +396,5 @@ processLogout :: Int -> PGS.Connection -> MateHandler () -processLogout uid conn = do +processLogout uid conn = void $ deleteTokenByUserId uid conn diff --git a/src/Model/Avatar.hs b/src/Model/Avatar.hs index 331ba0c..96ec3aa 100644 --- a/src/Model/Avatar.hs +++ b/src/Model/Avatar.hs @@ -137,6 +137,6 @@ updateAvatar aid (AvatarData name dat) conn = liftIO $ do , C.constant (encodeUtf8 dat) ) ) - , uWhere = (\(did, _, _, _) -> did .== C.constant aid) + , uWhere = \(did, _, _, _) -> did .== C.constant aid , uReturning = rCount } diff --git a/src/Model/Journal.hs b/src/Model/Journal.hs index 2323ca8..d487f2a 100644 --- a/src/Model/Journal.hs +++ b/src/Model/Journal.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE Arrows #-} module Model.Journal where @@ -130,7 +131,7 @@ insertNewJournalEntry -> PGS.Connection -> MateHandler Int insertNewJournalEntry (JournalSubmit descr amount) conn = do - lastTotal <- (\x -> case x of + lastTotal <- (\case Just j -> journalEntryTotalAmount j Nothing -> 0 ) <$> selectLatestJournalEntry conn diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 06f6c7b..02a63e5 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -105,7 +105,7 @@ productOverviewSelect refine conn = do prods <- liftIO $ runSelect conn ( proc () -> do (pid, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< () - (a1, a2, a3, a4, a5) <- + (a1, _, a3, _, _) <- limit 1 ( orderBy (desc (\(_, ts, _, _, _) -> ts)) (queryTable amountTable)) -< () @@ -144,22 +144,22 @@ productOverviewSelect refine conn = do ) ] (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts - ii5 <- return $ (\(_, x) -> x) $ - foldl - (\(bef, van) (_, _, amo, _, ver) -> + 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, if amo < bef then van + (bef - amo) else van) - else (amo, van) + then (amo, tot) + else (amo, tot + max 0 (bef - amo)) ) - (0, 0) - (Prelude.reverse amounts) - ii10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) -> - if ver - then (amo, tot) - else (amo, tot + max 0 (bef - amo)) - ) - (0, 0) - (Prelude.reverse amounts) + (0, 0) + (Prelude.reverse amounts) return $ ProductOverview i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9 ) @@ -205,22 +205,22 @@ productOverviewSelectSingle pid conn = do ) ] (ii3, ii4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts - ii5 <- return $ (\(_, x) -> x) $ - foldl - (\(bef, van) (_, _, amo, _, ver) -> + 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, if amo < bef then van + (bef - amo) else van) - else (amo, van) + then (amo, tot) + else (amo, tot + max 0 (bef - amo)) ) - (0, 0) - (Prelude.reverse amounts) - ii10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) -> - if ver - then (amo, tot) - else (amo, tot + max 0 (bef - amo)) - ) - (0, 0) - (Prelude.reverse amounts) + (0, 0) + (Prelude.reverse amounts) return $ ProductOverview i1 i2 ii3 ii4 ii5 i3 i4 i5 i6 ii10 i7 i8 i9 ) @@ -235,7 +235,7 @@ productShortOverviewSelect refine conn = do prods <- liftIO $ runSelect conn ( proc () -> do (i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< () - (a1, a2, a3, a4, a5) <- + (a1, _, a3, _, _) <- limit 1 ( orderBy (desc (\(_, ts, _, _, _) -> ts)) (queryTable amountTable)) -< () diff --git a/src/Model/User.hs b/src/Model/User.hs index bb84cb9..c158220 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -70,7 +70,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, _, _) -> @@ -138,9 +138,7 @@ userBalanceSelect conn uid = do ) ] head <$> mapM - (\(_, _, i3, _, _, _) -> return $ - i3 - ) + (\(_, _, i3, _, _, _) -> return i3) users @@ -183,7 +181,7 @@ updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update , C.constant (userDetailsSubmitAvatar uds) ) ) - , uWhere = (\(i1, _, _, _, _, _) -> i1 .== C.constant uid) + , uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid , uReturning = rCount } @@ -203,6 +201,6 @@ addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update , i6 ) ) - , uWhere = (\(i1, _, _, _, _, _) -> i1 .== C.constant uid) + , uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid , uReturning = rCount } diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index c2ad45b..fc21e23 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} module Types.Auth where diff --git a/src/Types/Journal.hs b/src/Types/Journal.hs index 2abbb9e..3bfa4fc 100644 --- a/src/Types/Journal.hs +++ b/src/Types/Journal.hs @@ -38,7 +38,7 @@ instance ToJSON JournalSubmit where instance FromJSON JournalSubmit -data JournalCashCheck = JournalCashCheck +newtype JournalCashCheck = JournalCashCheck { journalCashCheckTotalAmount :: Int } deriving (Generic, Show) diff --git a/src/Types/User.hs b/src/Types/User.hs index f1ed0b9..136e327 100644 --- a/src/Types/User.hs +++ b/src/Types/User.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} module Types.User where import GHC.Generics @@ -85,7 +84,7 @@ instance ToJSON UserDetailsSubmit where instance FromJSON UserDetailsSubmit -data UserRecharge = UserRecharge +newtype UserRecharge = UserRecharge { userRechargeAmount :: Int } deriving (Generic, Show)