From 9d05c4cf237e0033b65c155014398351ed697888 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 14 Jul 2021 03:08:58 +0200 Subject: [PATCH] linted --- src/Control/User.hs | 34 +++++----- src/Model/Amount.hs | 53 ++++++++------- src/Model/Auth.hs | 49 +++++++------- src/Model/Avatar.hs | 23 ++++--- src/Model/Journal.hs | 28 ++++---- src/Model/Product.hs | 71 ++++++++++----------- src/Model/Role.hs | 145 +++++++++++++++++++++--------------------- src/Model/User.hs | 45 +++++++------ src/Types/Purchase.hs | 2 +- 9 files changed, 221 insertions(+), 229 deletions(-) diff --git a/src/Control/User.hs b/src/Control/User.hs index a8663b2..8343331 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -150,7 +150,7 @@ userNotify -> [PurchaseDetail] -> PurchaseResult -> MateHandler () -userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do +userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do conn <- asks rsConnection authOV <- selectAuthOverviewById auid conn userDetails <- userDetailsSelect (authOverviewUser authOV) conn @@ -166,7 +166,7 @@ userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do boughtItems currencyFrac <- asks rsCurrencyFraction currencySymb <- asks rsCurrencySymbol - let messageText = T.pack $ mconcat $ map (<> ("\n")) $ + let messageText = T.pack $ mconcat $ map (<> "\n") $ [ printf (__ "Hello %s,") (userDetailsIdent userDetails) , "" , printf (__ "Your authentication key with the comment \"%s\"\ @@ -174,38 +174,39 @@ userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do (authOverviewComment authOV) , "" ] ++ - ( map + map (\(amount, ident, price) -> printf ("%dx %s " <> - (__ "for the price of") <> + __ "for the price of" <> "%d %f." <> - (printf "%d" currencyFrac) <> - (printf "%s" currencySymb) + printf "%d" currencyFrac <> + printf "%s" currencySymb ) amount ident price ) digestedDetails - ) ++ [ "" , printf (__ "For a total price of %s%s") <> - (printf + printf ("%f." <> (printf "%d" currencyFrac :: String)) - ((fromIntegral $ + (fromIntegral ( foldl (\acc (_, _, p) -> acc + p) 0 digestedDetails ) / - (fromIntegral $ 10 ^ currencyFrac) - :: Float )) + fromIntegral (10 ^ currencyFrac :: Int) + :: Float ) currencySymb , "" - , (__ "Enjoy your purchased items!\n\nSincerely,\nMateamt") - ] + , __ "Enjoy your purchased items!\n\nSincerely,\nMateamt" + ] ++ + [ __ "P.S.: You are now in debt. Please recharge your credit." | + flag == PurchaseDebtful ] case userDetailsEmail userDetails of Just _ -> do sendUserNotification @@ -214,6 +215,7 @@ userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do messageText Nothing -> return () - -- throwError $ err501 - -- { errBody = "userNotify: Not implemented yet" - -- } +userNotify Nothing _ _ = + throwError $ err401 + { errBody = "No Authentication present." + } diff --git a/src/Model/Amount.hs b/src/Model/Amount.hs index ec48ab6..94186a2 100644 --- a/src/Model/Amount.hs +++ b/src/Model/Amount.hs @@ -13,7 +13,6 @@ import Control.Arrow ((<<<)) import Control.Monad.IO.Class (liftIO) import Opaleye as O -import Opaleye.Constant as C -- internal imports @@ -67,11 +66,11 @@ insertNewEmptyAmount bevid (ProductSubmit _ price _ _ _ _ _ _ _ _) conn = { iTable = amountTable , iRows = [ - ( C.constant bevid - , C.constant now - , C.constant (0 :: Int) - , C.constant price - , C.constant False + ( toFields bevid + , toFields now + , toFields (0 :: Int) + , toFields price + , toFields False ) ] , iReturning = rReturning (\(id_, _, _, _, _) -> id_) @@ -85,8 +84,8 @@ getLatestPriceByProductId getLatestPriceByProductId pid conn = do liftIO $ amountPrice . fromDatabase . head <$> runSelect conn ( limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) - (keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) - <<< queryTable amountTable) + (keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) + <<< selectTable amountTable) ) getLatestAmountByProductId @@ -96,8 +95,8 @@ getLatestAmountByProductId getLatestAmountByProductId pid conn = do liftIO $ amountAmount . fromDatabase . head <$> runSelect conn ( limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) - (keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) - <<< queryTable amountTable) + (keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) + <<< selectTable amountTable) ) getLatestTotalPrice @@ -108,8 +107,8 @@ getLatestTotalPrice (PurchaseDetail pid amount) conn = do liftIO $ (amount *) . amountPrice . fromDatabase . head <$> runSelect conn ( limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $ - keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< - queryTable amountTable + keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) <<< + selectTable amountTable ) checkProductAvailability @@ -118,10 +117,10 @@ checkProductAvailability -> MateHandler (Maybe Int) -- ^ Returns maybe missing amount checkProductAvailability (PurchaseDetail pid amount) conn = do realamount <- amountAmount . fromDatabase . head <$> - (liftIO $ runSelect conn $ limit 1 $ + liftIO (runSelect conn $ limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $ - keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< - queryTable amountTable + keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) <<< + selectTable amountTable ) if realamount < amount then return (Just $ amount - realamount) @@ -142,11 +141,11 @@ manualProductAmountUpdate aups conn = { iTable = amountTable , iRows = [ - ( C.constant pid - , C.constant now - , C.constant amount - , C.constant oldprice - , C.constant True + ( toFields pid + , toFields now + , toFields amount + , toFields oldprice + , toFields True ) ] , iReturning = rReturning (\(id_, _, _, _, _) -> id_) @@ -167,8 +166,8 @@ postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do (\am -> (amountAmount am, amountPrice am)) . fromDatabase . head <$> ( liftIO $ runSelect conn $ limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $ - keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< - queryTable amountTable + keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) <<< + selectTable amountTable :: MateHandler [ ( Int , UTCTime @@ -182,11 +181,11 @@ postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do { iTable = amountTable , iRows = [ - ( C.constant pid - , C.constant now - , C.constant (amount - pdamount) - , C.constant oldprice - , C.constant False + ( toFields pid + , toFields now + , toFields (amount - pdamount) + , toFields oldprice + , toFields False ) ] , iReturning = rReturning (\(id_, _, _, _, _) -> id_) diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index ee00b0a..a8a291f 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -33,7 +33,6 @@ import Data.ByteString.Random import qualified Data.ByteString.Base64 as B64 import Opaleye hiding (null) -import qualified Opaleye.Constant as C -- internal imports @@ -123,8 +122,8 @@ selectAuthOverviews selectAuthOverviews uid conn = do liftIO $ map fromDatabase <$> runSelect conn (proc () -> do (adid, aduid, admethod, adcomment, _) <- - queryTable authDataTable -< () - restrict -< aduid .== C.constant uid + selectTable authDataTable -< () + restrict -< aduid .== toFields uid returnA -< (adid, aduid, adcomment, admethod) ) @@ -134,10 +133,10 @@ selectAuthOverviewById -> PGS.Connection -- ^ Connection Handler -> MateHandler AuthOverview selectAuthOverviewById aid conn = do - liftIO $ fromDatabase <$> head <$> runSelect conn (limit 1 $ proc () -> do + liftIO $ fromDatabase . head <$> runSelect conn (limit 1 $ proc () -> do (adid, aduid, admethod, adcomment, _) <- - queryTable authDataTable -< () - restrict -< adid .== C.constant aid + selectTable authDataTable -< () + restrict -< adid .== toFields aid returnA -< (adid, aduid, adcomment, admethod) ) @@ -153,9 +152,9 @@ getUserAuthInfo uid method conn = do void $ threadDelay delayTime map fromDatabase <$> runSelect conn (proc () -> do (aid, auid, amethod, acomment, apayload) <- - queryTable authDataTable -< () + selectTable authDataTable -< () restrict -< - auid .== C.constant uid .&& amethod .== C.constant (fromEnum method) + auid .== toFields uid .&& amethod .== toFields (fromEnum method) returnA -< (aid, auid, amethod, acomment, apayload) ) :: IO [AuthData] if null authdata @@ -183,11 +182,11 @@ putUserAuthInfo uid method comment payload conn = { iTable = authDataTable , iRows = [ - ( C.constant (Nothing :: Maybe Int) - , C.constant uid - , C.constant (fromEnum method) - , C.constant comment - , C.constant (either error id $ B64.decode $ encodeUtf8 payload) + ( toFields (Nothing :: Maybe Int) + , toFields uid + , toFields (fromEnum method) + , toFields comment + , toFields (either error id $ B64.decode $ encodeUtf8 payload) ) ] , iReturning = rReturning (\(adid, _, _, _, _) -> adid) @@ -201,7 +200,7 @@ deleteAuthDataById -> MateHandler Int64 deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete { dTable = authDataTable - , dWhere = \(aid, _, _, _, _) -> aid .== C.constant adid + , dWhere = \(aid, _, _, _, _) -> aid .== toFields adid , dReturning = rCount } @@ -213,10 +212,10 @@ validateToken validateToken header conn = do tokens <- liftIO $ map fromDatabase <$> runSelect conn ( keepWhen (\(tstr, _, _, _) -> - tstr .== C.constant (decodeUtf8 header)) <<< queryTable tokenTable + tstr .== toFields (decodeUtf8 header)) <<< selectTable tokenTable ) case tokens of - [(Token _ uid stamp method)] -> do + [Token _ uid stamp method] -> do now <- liftIO getCurrentTime if diffUTCTime stamp now > 0 then return $ Just (uid, method) @@ -241,8 +240,8 @@ generateToken generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do authData <- liftIO $ map fromDatabase <$> runSelect conn ( keepWhen (\(_, auid, amethod, _, _) -> - auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method)) - <<< queryTable authDataTable + auid .== toFields tuid .&& amethod .== toFields (fromEnum method)) + <<< selectTable authDataTable ) :: MateHandler [AuthData] let userPayloads = map authDataPayload @@ -279,10 +278,10 @@ insertToken (Token tString tUser tExpiry tMethod) conn = { iTable = tokenTable , iRows = [ - ( C.constant tString - , C.constant tUser - , C.constant tExpiry - , C.constant (fromEnum tMethod) + ( toFields tString + , toFields tUser + , toFields tExpiry + , toFields (fromEnum tMethod) ) ] , iReturning = rReturning (\(ident, _, _, _) -> ident) @@ -297,7 +296,7 @@ deleteToken deleteToken tstr conn = liftIO $ runDelete_ conn $ Delete { dTable = tokenTable - , dWhere = \(rtstr, _, _, _) -> rtstr .== C.constant tstr + , dWhere = \(rtstr, _, _, _) -> rtstr .== toFields tstr , dReturning = rCount } @@ -308,7 +307,7 @@ deleteTokenByUserId -> MateHandler Int64 deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete { dTable = tokenTable - , dWhere = \(_, rid, _, _) -> rid .== C.constant uid + , dWhere = \(_, rid, _, _) -> rid .== toFields uid , dReturning = rCount } @@ -319,7 +318,7 @@ deleteOldTokens -> IO Int64 deleteOldTokens now conn = runDelete_ conn $ Delete { dTable = tokenTable - , dWhere = \(_, _, expiry, _) -> expiry .< C.constant now + , dWhere = \(_, _, expiry, _) -> expiry .< toFields now , dReturning = rCount } diff --git a/src/Model/Avatar.hs b/src/Model/Avatar.hs index 96ec3aa..9e4f80e 100644 --- a/src/Model/Avatar.hs +++ b/src/Model/Avatar.hs @@ -21,7 +21,6 @@ import Control.Arrow import Control.Monad.IO.Class (liftIO) import Opaleye as O -import Opaleye.Constant as C -- internal imports @@ -64,7 +63,7 @@ avatarSelect conn = liftIO $ do avatars <- runSelect conn ( proc () -> do ret <- orderBy (desc (\(_, name, _, _) -> name)) - (queryTable avatarTable) -< () + (selectTable avatarTable) -< () returnA -< ret ) :: IO @@ -86,8 +85,8 @@ avatarSelectById -> IO [Avatar] avatarSelectById aid conn = do avatars <- runSelect conn ( - keepWhen (\(aaid, _, _, _) -> aaid .== C.constant aid) - <<< queryTable avatarTable) + keepWhen (\(aaid, _, _, _) -> aaid .== toFields aid) + <<< selectTable avatarTable) :: IO [ ( Int , T.Text @@ -111,10 +110,10 @@ insertAvatar (AvatarData name dat) conn = fmap head $ liftIO $ do { iTable = avatarTable , iRows = [ - ( C.constant (Nothing :: Maybe Int) - , C.constant name - , C.constant hash - , C.constant (encodeUtf8 dat) + ( toFields (Nothing :: Maybe Int) + , toFields name + , toFields hash + , toFields (encodeUtf8 dat) ) ] , iReturning = rReturning (\(aid, _, _, _) -> aid) @@ -132,11 +131,11 @@ updateAvatar aid (AvatarData name dat) conn = liftIO $ do { uTable = avatarTable , uUpdateWith = updateEasy (\(did, _, _, _) -> ( did - , C.constant name - , C.constant hash - , C.constant (encodeUtf8 dat) + , toFields name + , toFields hash + , toFields (encodeUtf8 dat) ) ) - , uWhere = \(did, _, _, _) -> did .== C.constant aid + , uWhere = \(did, _, _, _) -> did .== toFields aid , uReturning = rCount } diff --git a/src/Model/Journal.hs b/src/Model/Journal.hs index ce94866..b7574e3 100644 --- a/src/Model/Journal.hs +++ b/src/Model/Journal.hs @@ -5,11 +5,8 @@ module Model.Journal where import Data.Maybe -import Data.Time (UTCTime) import Data.Time.Clock -import qualified Data.Text as T - import Data.Profunctor.Product (p5) import qualified Database.PostgreSQL.Simple as PGS @@ -17,7 +14,6 @@ import qualified Database.PostgreSQL.Simple as PGS import Control.Arrow import Opaleye as O hiding (null, not) -import Opaleye.Constant as C import Control.Monad.IO.Class (liftIO) @@ -78,7 +74,7 @@ selectJournalEntries mlimit moffset conn = liftIO $ do entries <- runSelect conn ( proc () -> do ret <- lim $ off $ orderBy (desc (\(id_, _, _, _, _) -> id_)) - (queryTable journalTable) -< () + (selectTable journalTable) -< () returnA -< ret ) :: IO [ ( Int @@ -109,7 +105,7 @@ selectLatestJournalEntry conn = liftIO $ do lastTwoEntries <- runSelect conn ( proc () -> do ret <- limit 2 (orderBy (desc (\(id_, _, _, _, _) -> id_)) - (queryTable journalTable)) -< () + (selectTable journalTable)) -< () returnA -< ret ) :: IO [ ( Int @@ -143,11 +139,11 @@ insertNewJournalEntry (JournalSubmit user action amount) conn = do { iTable = journalTable , iRows = [ - ( C.constant (Nothing :: Maybe Int) - , C.constant now - , C.constant user - , C.constant (fromEnum action) - , C.constant (lastTotal + amount) + ( toFields (Nothing :: Maybe Int) + , toFields now + , toFields user + , toFields (fromEnum action) + , toFields (lastTotal + amount) ) ] , iReturning = rReturning (\(id_, _, _, _, _) -> id_) @@ -169,11 +165,11 @@ insertNewCashCheck (JournalCashCheck user amount) conn = { iTable = journalTable , iRows = [ - ( C.constant (Nothing :: Maybe Int) - , C.constant now - , C.constant (Just user) - , C.constant (fromEnum CashCheck) - , C.constant amount + ( toFields (Nothing :: Maybe Int) + , toFields now + , toFields (Just user) + , toFields (fromEnum CashCheck) + , toFields amount ) ] , iReturning = rReturning (\(id_, _, _, _, _) -> id_) diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 173e8df..a065e29 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -22,7 +22,6 @@ import qualified Database.PostgreSQL.Simple as PGS import qualified Data.Profunctor as P import Opaleye as O -import Opaleye.Constant as C -- internal imports @@ -90,7 +89,7 @@ productSelect -> MateHandler [Product] productSelect conn = do liftIO $ map fromDatabase <$> runSelect conn - (queryTable productTable) + (selectTable productTable) productSelectSingle @@ -101,8 +100,8 @@ productSelectSingle pid conn = do prods <- liftIO $ map fromDatabase <$> runSelect conn ( limit 1 (keepWhen ( - \(id_, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid - ) <<< queryTable productTable) + \(id_, _, _, _, _, _, _, _, _, _) -> id_ .== toFields pid + ) <<< selectTable productTable) ) case prods of p:_ -> return (Just p) @@ -144,18 +143,18 @@ produceProductOverviews refine = (pid, pi2, pi6, pi6a, pi7, pi8, pi9, pi11, pi12, pi13, ai3, ai4) ) (const - ( C.constant (0 :: Int) :: Column PGInt4 - , C.constant ("ERROR PRODUCT" :: T.Text) :: Column PGText - , C.constant (0 :: Int) :: Column PGInt4 - , C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4) - , C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4) - , C.constant (0 :: Int) :: Column PGInt4 - , C.constant (0 :: Int) :: Column PGInt4 - , C.constant (0 :: Int) :: Column PGInt4 - , C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4) - , C.constant (Just ("" :: T.Text)) :: Column (Nullable PGText) - , C.constant (0 :: Int) :: Column PGInt4 - , C.constant (0 :: Int) :: Column PGInt4 + ( toFields (0 :: Int) :: Column PGInt4 + , toFields ("ERROR PRODUCT" :: T.Text) :: Column PGText + , toFields (0 :: Int) :: Column PGInt4 + , toFields (Just (0 :: Int)) :: Column (Nullable PGInt4) + , toFields (Just (0 :: Int)) :: Column (Nullable PGInt4) + , toFields (0 :: Int) :: Column PGInt4 + , toFields (0 :: Int) :: Column PGInt4 + , toFields (0 :: Int) :: Column PGInt4 + , toFields (Just (0 :: Int)) :: Column (Nullable PGInt4) + , toFields (Just ("" :: T.Text)) :: Column (Nullable PGText) + , toFields (0 :: Int) :: Column PGInt4 + , toFields (0 :: Int) :: Column PGInt4 ) ) (\(pid, _, _, _, _, _, _, _, _, _) @@ -180,9 +179,9 @@ produceProductOverviews refine = )) -< () -- <<< arr (\_ -> (selectTable productTable, selectTable amountTable)) -< () restrict -< case refine of - AllProducts -> C.constant True - AvailableProducts -> a3 ./= (C.constant (0 :: Int) :: Column PGInt4) - DepletedProducts -> a3 .== (C.constant (0 :: Int) :: Column PGInt4) + AllProducts -> toFields True + AvailableProducts -> a3 ./= (toFields (0 :: Int) :: Column PGInt4) + DepletedProducts -> a3 .== (toFields (0 :: Int) :: Column PGInt4) returnA -< (p, i2, i6, i6a, i7, i8, i9, i11, i12, i13, a3, a4) queryAmounts @@ -191,8 +190,8 @@ queryAmounts -> IO [Amount] queryAmounts conn pid = map fromDatabase <$> runSelect conn (proc () -> do stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts)) - (queryTable amountTable) -< () - restrict -< C.constant pid .== a1 + (selectTable amountTable) -< () + restrict -< toFields pid .== a1 returnA -< stuff ) @@ -281,16 +280,16 @@ insertProduct (ProductSubmit ident _ ml ava sup maxi mini apc ppc artnr) conn = { iTable = productTable , iRows = [ - ( C.constant (Nothing :: Maybe Int) - , C.constant ident - , C.constant ml - , C.constant ava - , C.constant sup - , C.constant maxi - , C.constant mini - , C.constant apc - , C.constant ppc - , C.constant artnr + ( toFields (Nothing :: Maybe Int) + , toFields ident + , toFields ml + , toFields ava + , toFields sup + , toFields maxi + , toFields mini + , toFields apc + , toFields ppc + , toFields artnr ) ] , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _) -> id_) @@ -314,11 +313,11 @@ manualProductAmountRefill aups conn = { iTable = amountTable , iRows = [ - ( C.constant pid - , C.constant now - , C.constant (oldamount + (amountSingles + (perCrate * amountCrates))) - , C.constant oldprice - , C.constant False + ( toFields pid + , toFields now + , toFields (oldamount + (amountSingles + (perCrate * amountCrates))) + , toFields oldprice + , toFields False ) ] , iReturning = rReturning (\(id_, _, _, _, _) -> id_) diff --git a/src/Model/Role.hs b/src/Model/Role.hs index 150a243..d2a0ea9 100644 --- a/src/Model/Role.hs +++ b/src/Model/Role.hs @@ -12,7 +12,6 @@ import qualified Data.Text as T import Data.Int (Int64) import Opaleye as O hiding (null, not) -import Opaleye.Constant as C import Control.Arrow ((<<<)) @@ -121,18 +120,18 @@ runInsertInitialRoles conn = do { iTable = roleTable , iRows = [ - ( C.constant (Nothing :: Maybe Int) - , C.constant ("Administrator" :: String) - , C.constant True - , C.constant True - , C.constant True - , C.constant True - , C.constant True - , C.constant True - , C.constant True - , C.constant True - , C.constant True - , C.constant True + ( toFields (Nothing :: Maybe Int) + , toFields ("Administrator" :: String) + , toFields True + , toFields True + , toFields True + , toFields True + , toFields True + , toFields True + , toFields True + , toFields True + , toFields True + , toFields True ) ] , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) @@ -142,18 +141,18 @@ runInsertInitialRoles conn = do { iTable = roleTable , iRows = [ - ( C.constant (Nothing :: Maybe Int) - , C.constant ("User" :: String) - , C.constant False - , C.constant False - , C.constant False - , C.constant False - , C.constant False - , C.constant False - , C.constant False - , C.constant False - , C.constant False - , C.constant False + ( toFields (Nothing :: Maybe Int) + , toFields ("User" :: String) + , toFields False + , toFields False + , toFields False + , toFields False + , toFields False + , toFields False + , toFields False + , toFields False + , toFields False + , toFields False ) ] , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) @@ -166,7 +165,7 @@ selectAllRoles -> MateHandler [Role] selectAllRoles conn = do liftIO $ map fromDatabase <$> runSelect conn ( - queryTable roleTable + selectTable roleTable ) :: MateHandler [Role] selectRoleList @@ -176,8 +175,8 @@ selectRoleList selectRoleList ids conn = do liftIO $ map fromDatabase <$> runSelect conn ( keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> - in_ (map C.constant ids) id_) - <<< queryTable roleTable + in_ (map toFields ids) id_) + <<< selectTable roleTable ) :: MateHandler [Role] insertRole @@ -199,18 +198,18 @@ insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 conn = do { iTable = roleTable , iRows = [ - ( C.constant (Nothing :: Maybe Int) - , C.constant name - , C.constant c1 - , C.constant c2 - , C.constant c3 - , C.constant c4 - , C.constant c5 - , C.constant c6 - , C.constant c7 - , C.constant c8 - , C.constant c9 - , C.constant c10 + ( toFields (Nothing :: Maybe Int) + , toFields name + , toFields c1 + , toFields c2 + , toFields c3 + , toFields c4 + , toFields c5 + , toFields c6 + , toFields c7 + , toFields c8 + , toFields c9 + , toFields c10 ) ] , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) @@ -225,29 +224,29 @@ queryRoleIdByName queryRoleIdByName name conn = do liftIO $ roleID . fromDatabase . head <$> runSelect conn ( keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _) -> - C.constant name .== rname) <<< queryTable roleTable + toFields name .== rname) <<< selectTable roleTable ) :: MateHandler Int queryRoleIdByCapabilities :: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) -> PGS.Connection -> MateHandler Int -queryRoleIdByCapabilities (p1, p2, p3, p4, p5, p6, p7, p8, p9, p10) conn = +queryRoleIdByCapabilities (pa1, pa2, pa3, pa4, pa5, pa6, pa7, pa8, pa9, pa10) conn = do liftIO $ roleID . fromDatabase . head <$> runSelect conn ( keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) -> - C.constant p1 .== c1 .&& - C.constant p2 .== c2 .&& - C.constant p3 .== c3 .&& - C.constant p4 .== c4 .&& - C.constant p5 .== c5 .&& - C.constant p6 .== c6 .&& - C.constant p7 .== c7 .&& - C.constant p8 .== c8 .&& - C.constant p9 .== c9 .&& - C.constant p10 .== c10 + toFields pa1 .== c1 .&& + toFields pa2 .== c2 .&& + toFields pa3 .== c3 .&& + toFields pa4 .== c4 .&& + toFields pa5 .== c5 .&& + toFields pa6 .== c6 .&& + toFields pa7 .== c7 .&& + toFields pa8 .== c8 .&& + toFields pa9 .== c9 .&& + toFields pa10 .== c10 ) - <<< queryTable roleTable + <<< selectTable roleTable ) :: MateHandler Int @@ -256,7 +255,7 @@ selectAllRoleAssociations -> MateHandler [RoleAssociation] selectAllRoleAssociations conn = do rawRoleAssocs <- liftIO $ runSelect conn ( - queryTable userToRoleTable + selectTable userToRoleTable ) :: MateHandler [ ( Int @@ -274,8 +273,8 @@ selectUserAssociations -> MateHandler [RoleAssociation] selectUserAssociations uid conn = do rawAssocs <- liftIO $ runSelect conn( - keepWhen (\(auid, _) -> auid .== C.constant uid) - <<< queryTable userToRoleTable + keepWhen (\(auid, _) -> auid .== toFields uid) + <<< selectTable userToRoleTable ) :: MateHandler [ ( Int @@ -295,8 +294,8 @@ associateUserToRole uid rid conn = { iTable = userToRoleTable , iRows = [ - ( C.constant uid - , C.constant rid + ( toFields uid + , toFields rid ) ] , iReturning = rReturning (const ()) @@ -313,7 +312,7 @@ deleteAssociation uid rid conn = liftIO $ runDelete_ conn $ Delete { dTable = userToRoleTable , dWhere = - \(auid, arid) -> auid .== C.constant uid .&& arid .== C.constant rid + \(auid, arid) -> auid .== toFields uid .&& arid .== toFields rid , dReturning = rCount } @@ -323,26 +322,26 @@ updateRole -> RoleSubmit -- The role with already updated info -> PGS.Connection -> MateHandler Int64 -updateRole rid role@(RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10) conn = +updateRole rid (RoleSubmit name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10) conn = liftIO $ runUpdate_ conn $ Update { uTable = roleTable , uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> ( id_ - , C.constant name - , C.constant c1 - , C.constant c2 - , C.constant c3 - , C.constant c4 - , C.constant c5 - , C.constant c6 - , C.constant c7 - , C.constant c8 - , C.constant c9 - , C.constant c10 + , toFields name + , toFields c1 + , toFields c2 + , toFields c3 + , toFields c4 + , toFields c5 + , toFields c6 + , toFields c7 + , toFields c8 + , toFields c9 + , toFields c10 ) ) , uWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _) -> - id_ .== C.constant rid + id_ .== toFields rid , uReturning = rCount } @@ -354,6 +353,6 @@ deleteRole rid conn = liftIO $ runDelete_ conn $ Delete { dTable = roleTable , dWhere = - \(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid + \(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== toFields rid , dReturning = rCount } diff --git a/src/Model/User.hs b/src/Model/User.hs index d434e46..d7d2524 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -16,7 +16,6 @@ import Control.Arrow ((<<<)) import Control.Monad.IO.Class (liftIO) import Opaleye as O -import qualified Opaleye.Constant as C -- internal imports @@ -73,11 +72,11 @@ userSelect ref conn = do orderBy (asc (\(_, ident, _, _, _, _) -> ident)) ( keepWhen (\(_, _, _, ts, _, _) -> case ref of AllUsers -> - C.constant True + toFields True ActiveUsers -> - ts .>= C.constant (addDays (-30) today) + ts .>= toFields (addDays (-30) today) OldUsers -> - ts .< C.constant (addDays (-30) today) + ts .< toFields (addDays (-30) today) ) <<< selectTable userTable) ) :: MateHandler [User] mapM @@ -93,8 +92,8 @@ userDetailsSelect userDetailsSelect uid conn = do users <- liftIO $ map fromDatabase <$> runSelect conn (limit 1 $ keepWhen (\(uuid, _, _, _, _, _) -> - uuid .== C.constant uid - ) <<< queryTable userTable + uuid .== toFields uid + ) <<< selectTable userTable ) :: MateHandler [User] head <$> mapM (\(User i1 i2 i3 _ i5 i6) -> return $ @@ -110,8 +109,8 @@ userBalanceSelect userBalanceSelect conn uid = do liftIO $ userBalance . fromDatabase . head <$> runSelect conn ( keepWhen (\(uuid, _, _, _, _, _) -> - uuid .== C.constant uid - ) <<< queryTable userTable + uuid .== toFields uid + ) <<< selectTable userTable ) @@ -125,12 +124,12 @@ insertUser ident email now conn = fmap head $ liftIO $ runInsert_ conn $ Insert { iTable = userTable , iRows = [ - ( C.constant (Nothing :: Maybe Int) - , C.constant ident - , C.constant (0 :: Int) - , C.constant now - , C.constant email - , C.constant (Nothing :: Maybe Int) + ( toFields (Nothing :: Maybe Int) + , toFields ident + , toFields (0 :: Int) + , toFields now + , toFields email + , toFields (Nothing :: Maybe Int) ) ] , iReturning = rReturning (\(uid, _, _, _, _, _) -> uid) @@ -147,14 +146,14 @@ updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update { uTable = userTable , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _) -> ( id_ - , C.constant (userDetailsSubmitIdent uds) + , toFields (userDetailsSubmitIdent uds) , i3 - , C.constant now - , C.constant (userDetailsSubmitEmail uds) - , C.constant (userDetailsSubmitAvatar uds) + , toFields now + , toFields (userDetailsSubmitEmail uds) + , toFields (userDetailsSubmitAvatar uds) ) ) - , uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid + , uWhere = \(i1, _, _, _, _, _) -> i1 .== toFields uid , uReturning = rCount } @@ -169,12 +168,12 @@ updateUserTimestamp uid now conn = liftIO $ runUpdate_ conn $ Update ( id_ , ident , balance - , C.constant now + , toFields now , email , ava ) ) - , uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid + , uWhere = \(i1, _, _, _, _, _) -> i1 .== toFields uid , uReturning = rCount } @@ -188,12 +187,12 @@ addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update , uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6) -> ( id_ , i2 - , i3 + C.constant amount + , i3 + toFields amount , i4 , i5 , i6 ) ) - , uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid + , uWhere = \(i1, _, _, _, _, _) -> i1 .== toFields uid , uReturning = rCount } diff --git a/src/Types/Purchase.hs b/src/Types/Purchase.hs index f4d03de..a4d6c89 100644 --- a/src/Types/Purchase.hs +++ b/src/Types/Purchase.hs @@ -35,7 +35,7 @@ data PurchaseResultFlag = PurchaseOK | PurchaseDebtful | PayAmount Int - deriving (Generic, Show) + deriving (Generic, Show, Eq) instance ToJSON PurchaseResultFlag where toEncoding = genericToEncoding defaultOptions