nek0/mateamt
1
0
Fork 0
Code Issues Pull requests Releases Activity

hunting warnings (deprecations mostly)

Browse source
This commit is contained in:
nek0 2022-04-15 15:35:53 +02:00
parent 221d4bf79b
commit 31f6c6d61e
8 changed files with 114 additions and 95 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/Classes/FromDatabase.hs
View file

@ -1,8 +1,10 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Classes.FromDatabase where module Classes.FromDatabase where
import Data.Kind (Type)
class FromDatabase a where class FromDatabase a where
type OutTuple a :: * type OutTuple a :: Type
fromDatabase :: OutTuple a -> a fromDatabase :: OutTuple a -> a

4
src/Classes/ToDatabase.hs
View file

@ -1,8 +1,10 @@
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
module Classes.ToDatabase where module Classes.ToDatabase where
import Data.Kind (Type)
class ToDatabase a where class ToDatabase a where
type InTuple a :: * type InTuple a :: Type
toDatabase :: a -> InTuple a toDatabase :: a -> InTuple a

65
src/Model/Amount.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Arrows #-}
module Model.Amount where module Model.Amount where
import Data.Time.Clock (getCurrentTime) import Data.Time.Clock (getCurrentTime)
@ -8,7 +9,7 @@ import Data.Profunctor.Product (p5)
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
import Control.Arrow ((<<<)) import Control.Arrow
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -61,13 +62,13 @@ insertNewEmptyAmount
-> MateHandler Int -> MateHandler Int
insertNewEmptyAmount bevid (ProductSubmit _ price _ _ _ _ _ _ _ _) conn = insertNewEmptyAmount bevid (ProductSubmit _ price _ _ _ _ _ _ _ _) conn =
liftIO $ do liftIO $ do
now <- getCurrentTime now_ <- getCurrentTime
fmap head $ runInsert_ conn $ Insert fmap head $ runInsert_ conn $ Insert
{ iTable = amountTable { iTable = amountTable
, iRows = , iRows =
[ [
( toFields bevid ( toFields bevid
, toFields now , toFields now_
, toFields (0 :: Int) , toFields (0 :: Int)
, toFields price , toFields price
, toFields False , toFields False
@ -82,10 +83,12 @@ getLatestPriceByProductId
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -- The price in cents -> MateHandler Int -- The price in cents
getLatestPriceByProductId pid conn = do getLatestPriceByProductId pid conn = do
liftIO $ amountPrice . fromDatabase . head <$> runSelect conn ( liftIO $ amountPrice . fromDatabase . head <$> runSelect conn (proc () -> do
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) stuff@(id_, _, _, _, _) <- limit 1 (orderBy (desc (\(_, ts, _, _, _) -> ts))
(keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) (selectTable amountTable)) -< ()
<<< selectTable amountTable)
restrict -< id_ .== toFields pid
returnA -< stuff
) )
getLatestAmountByProductId getLatestAmountByProductId
@ -93,10 +96,12 @@ getLatestAmountByProductId
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -- The amount -> MateHandler Int -- The amount
getLatestAmountByProductId pid conn = do getLatestAmountByProductId pid conn = do
liftIO $ amountAmount . fromDatabase . head <$> runSelect conn ( liftIO $ amountAmount . fromDatabase . head <$> runSelect conn ( proc () -> do
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) stuff@(id_, _, _, _, _) <-
(keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) limit 1 (orderBy (desc (\(_, ts, _, _, _) -> ts)) (selectTable amountTable)) -<
<<< selectTable amountTable) ()
restrict -< id_ .== toFields pid
returnA -< stuff
) )
getLatestTotalPrice getLatestTotalPrice
@ -105,11 +110,12 @@ getLatestTotalPrice
-> MateHandler Int -- The price in cents -> MateHandler Int -- The price in cents
getLatestTotalPrice (PurchaseDetail pid amount) conn = do getLatestTotalPrice (PurchaseDetail pid amount) conn = do
liftIO $ (amount *) . amountPrice . fromDatabase . head <$> liftIO $ (amount *) . amountPrice . fromDatabase . head <$>
runSelect conn ( runSelect conn (proc () -> do
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $ stuff@(id_, _, _, _, _) <-
keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) <<< limit 1 (orderBy (desc (\(_, ts, _, _, _) -> ts)) (selectTable amountTable)) -<
selectTable amountTable ()
) restrict -< id_ .== toFields pid
returnA -< stuff)
checkProductAvailability checkProductAvailability
:: PurchaseDetail :: PurchaseDetail
@ -117,10 +123,12 @@ checkProductAvailability
-> MateHandler (Maybe Int) -- ^ Returns maybe missing amount -> MateHandler (Maybe Int) -- ^ Returns maybe missing amount
checkProductAvailability (PurchaseDetail pid amount) conn = do checkProductAvailability (PurchaseDetail pid amount) conn = do
realamount <- amountAmount . fromDatabase . head <$> realamount <- amountAmount . fromDatabase . head <$>
liftIO (runSelect conn $ limit 1 $ liftIO (runSelect conn $ proc () -> do
orderBy (desc (\(_, ts, _, _, _) -> ts)) $ stuff@(id_, _, _, _, _) <-
keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) <<< limit 1 (orderBy (desc (\(_, ts, _, _, _) -> ts)) (selectTable amountTable)) -<
selectTable amountTable ()
restrict -< id_ .== toFields pid
returnA -< stuff
) )
if realamount < amount if realamount < amount
then return (Just $ amount - realamount) then return (Just $ amount - realamount)
@ -136,13 +144,13 @@ manualProductAmountUpdate aups conn =
(\(AmountUpdate pid amount) -> do (\(AmountUpdate pid amount) -> do
oldprice <- getLatestPriceByProductId pid conn oldprice <- getLatestPriceByProductId pid conn
head <$> liftIO (do head <$> liftIO (do
now <- getCurrentTime now_ <- getCurrentTime
runInsert_ conn $ Insert runInsert_ conn $ Insert
{ iTable = amountTable { iTable = amountTable
, iRows = , iRows =
[ [
( toFields pid ( toFields pid
, toFields now , toFields now_
, toFields amount , toFields amount
, toFields oldprice , toFields oldprice
, toFields True , toFields True
@ -161,13 +169,14 @@ postBuyProductAmountUpdate
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> MateHandler Int
postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do
now <- liftIO getCurrentTime now_ <- liftIO getCurrentTime
(amount, oldprice) <- (amount, oldprice) <-
(\am -> (amountAmount am, amountPrice am)) . fromDatabase . head <$> ( (\am -> (amountAmount am, amountPrice am)) . fromDatabase . head <$> (
liftIO $ runSelect conn $ limit 1 $ liftIO $ runSelect conn (proc () -> do
orderBy (desc (\(_, ts, _, _, _) -> ts)) $ stuff@(id_, _, _, _, _) <-
keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) <<< limit 1 (orderBy (desc (\(_, ts, _, _, _) -> ts)) (selectTable amountTable)) -< ()
selectTable amountTable restrict -< id_ .== toFields pid
returnA -< stuff)
:: MateHandler :: MateHandler
[ ( Int [ ( Int
, UTCTime , UTCTime
@ -182,7 +191,7 @@ postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do
, iRows = , iRows =
[ [
( toFields pid ( toFields pid
, toFields now , toFields now_
, toFields (amount - pdamount) , toFields (amount - pdamount)
, toFields oldprice , toFields oldprice
, toFields False , toFields False

25
src/Model/Auth.hs
View file

@ -211,13 +211,15 @@ validateToken
-> Handler (Maybe (Int, AuthMethod)) -> Handler (Maybe (Int, AuthMethod))
validateToken header conn = do validateToken header conn = do
tokens <- liftIO $ map fromDatabase <$> runSelect conn ( tokens <- liftIO $ map fromDatabase <$> runSelect conn (
keepWhen (\(tstr, _, _, _) -> proc () -> do
tstr .== toFields (decodeUtf8 header)) <<< selectTable tokenTable stuff@(tstr, _, _, _) <- (selectTable tokenTable) -< ()
restrict -< toFields (decodeUtf8 header) .== tstr
returnA -< stuff
) )
case tokens of case tokens of
[Token _ uid stamp method] -> do [Token _ uid stamp method] -> do
now <- liftIO getCurrentTime now_ <- liftIO getCurrentTime
if diffUTCTime stamp now > 0 if diffUTCTime stamp now_ > 0
then return $ Just (uid, method) then return $ Just (uid, method)
else do else do
void $ deleteToken (decodeUtf8 header) conn void $ deleteToken (decodeUtf8 header) conn
@ -239,9 +241,10 @@ generateToken
-> MateHandler AuthResult -> MateHandler AuthResult
generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
authData <- liftIO $ map fromDatabase <$> runSelect conn ( authData <- liftIO $ map fromDatabase <$> runSelect conn (
keepWhen (\(_, auid, amethod, _, _) -> proc () -> do
auid .== toFields tuid .&& amethod .== toFields (fromEnum method)) stuff@(_, auid, amethod, _, _) <- selectTable authDataTable -< ()
<<< selectTable authDataTable restrict -< (auid .== toFields tuid .&& amethod .== toFields (fromEnum method))
returnA -< stuff
) :: MateHandler [AuthData] ) :: MateHandler [AuthData]
let userPayloads = map let userPayloads = map
authDataPayload authDataPayload
@ -316,9 +319,9 @@ deleteOldTokens
:: UTCTime :: UTCTime
-> PGS.Connection -> PGS.Connection
-> IO Int64 -> IO Int64
deleteOldTokens now conn = runDelete_ conn $ Delete deleteOldTokens now_ conn = runDelete_ conn $ Delete
{ dTable = tokenTable { dTable = tokenTable
, dWhere = \(_, _, expiry, _) -> expiry .< toFields now , dWhere = \(_, _, expiry, _) -> expiry .< toFields now_
, dReturning = rCount , dReturning = rCount
} }
@ -351,9 +354,9 @@ processAuthRequest (AuthRequest aticket hash) store conn = do
case S.toList mticket of case S.toList mticket of
[ticket] -> do [ticket] -> do
-- liftIO $ putStrLn "there is a ticket..." -- liftIO $ putStrLn "there is a ticket..."
now <- liftIO getCurrentTime now_ <- liftIO getCurrentTime
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
if now > ticketExpiry ticket if now_ > ticketExpiry ticket
then then
return Denied return Denied
else else

8
src/Model/Avatar.hs
View file

@ -84,9 +84,11 @@ avatarSelectById
-> PGS.Connection -> PGS.Connection
-> IO [Avatar] -> IO [Avatar]
avatarSelectById aid conn = do avatarSelectById aid conn = do
avatars <- runSelect conn ( avatars <- runSelect conn (proc () -> do
keepWhen (\(aaid, _, _, _) -> aaid .== toFields aid) stuff@(aaid, _, _, _) <- selectTable avatarTable -< ()
<<< selectTable avatarTable) restrict -< aaid .== toFields aid
returnA -< stuff
)
:: IO :: IO
[ ( Int [ ( Int
, T.Text , T.Text

8
src/Model/Journal.hs
View file

@ -134,13 +134,13 @@ insertNewJournalEntry (JournalSubmit user action amount) conn = do
Nothing -> 0 Nothing -> 0
) <$> selectLatestJournalEntry conn ) <$> selectLatestJournalEntry conn
liftIO $ do liftIO $ do
now <- getCurrentTime now_ <- getCurrentTime
fmap head $ runInsert_ conn $ Insert fmap head $ runInsert_ conn $ Insert
{ iTable = journalTable { iTable = journalTable
, iRows = , iRows =
[ [
( toFields (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, toFields now , toFields now_
, toFields user , toFields user
, toFields (fromEnum action) , toFields (fromEnum action)
, toFields (lastTotal + amount) , toFields (lastTotal + amount)
@ -160,13 +160,13 @@ insertNewCashCheck (JournalCashCheck user amount) conn =
-- Nothing -> 0 -- Nothing -> 0
-- ) <$> selectLatestJournalEntry conn -- ) <$> selectLatestJournalEntry conn
liftIO $ do liftIO $ do
now <- getCurrentTime now_ <- getCurrentTime
fmap head $ runInsert_ conn $ Insert fmap head $ runInsert_ conn $ Insert
{ iTable = journalTable { iTable = journalTable
, iRows = , iRows =
[ [
( toFields (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, toFields now , toFields now_
, toFields (Just user) , toFields (Just user)
, toFields (fromEnum CashCheck) , toFields (fromEnum CashCheck)
, toFields amount , toFields amount

62
src/Model/Product.hs
View file

@ -97,12 +97,10 @@ productSelectSingle
-> PGS.Connection -> PGS.Connection
-> MateHandler (Maybe Product) -> MateHandler (Maybe Product)
productSelectSingle pid conn = do productSelectSingle pid conn = do
prods <- liftIO $ map fromDatabase <$> runSelect conn prods <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do
( limit 1 stuff@(id_, _, _, _, _, _, _, _, _, _) <- limit 1 (selectTable productTable) -< ()
(keepWhen ( restrict -< id_ .== toFields pid
\(id_, _, _, _, _, _, _, _, _, _) -> id_ .== toFields pid returnA -< stuff)
) <<< selectTable productTable)
)
case prods of case prods of
p:_ -> return (Just p) p:_ -> return (Just p)
_ -> return Nothing _ -> return Nothing
@ -121,18 +119,18 @@ productOverviewSelect refine conn = do
produceProductOverviews produceProductOverviews
:: ProductRefine :: ProductRefine
-> Select -> Select
( Column PGInt4 ( Column SqlInt4
, Column PGText , Column SqlText
, Column PGInt4 , Column SqlInt4
, Column (Nullable PGInt4) , Column (Nullable SqlInt4)
, Column (Nullable PGInt4) , Column (Nullable SqlInt4)
, Column PGInt4 , Column SqlInt4
, Column PGInt4 , Column SqlInt4
, Column PGInt4 , Column SqlInt4
, Column (Nullable PGInt4) , Column (Nullable SqlInt4)
, Column (Nullable PGText) , Column (Nullable SqlText)
, Column PGInt4 , Column SqlInt4
, Column PGInt4 , Column SqlInt4
) )
produceProductOverviews refine = produceProductOverviews refine =
proc () -> do proc () -> do
@ -143,18 +141,18 @@ produceProductOverviews refine =
(pid, pi2, pi6, pi6a, pi7, pi8, pi9, pi11, pi12, pi13, ai3, ai4) (pid, pi2, pi6, pi6a, pi7, pi8, pi9, pi11, pi12, pi13, ai3, ai4)
) )
(const (const
( toFields (0 :: Int) :: Column PGInt4 ( toFields (0 :: Int) :: Column SqlInt4
, toFields ("ERROR PRODUCT" :: T.Text) :: Column PGText , toFields ("ERROR PRODUCT" :: T.Text) :: Column SqlText
, toFields (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column SqlInt4
, toFields (Just (0 :: Int)) :: Column (Nullable PGInt4) , toFields (Just (0 :: Int)) :: Column (Nullable SqlInt4)
, toFields (Just (0 :: Int)) :: Column (Nullable PGInt4) , toFields (Just (0 :: Int)) :: Column (Nullable SqlInt4)
, toFields (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column SqlInt4
, toFields (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column SqlInt4
, toFields (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column SqlInt4
, toFields (Just (0 :: Int)) :: Column (Nullable PGInt4) , toFields (Just (0 :: Int)) :: Column (Nullable SqlInt4)
, toFields (Just ("" :: T.Text)) :: Column (Nullable PGText) , toFields (Just ("" :: T.Text)) :: Column (Nullable SqlText)
, toFields (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column SqlInt4
, toFields (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column SqlInt4
) )
) )
(\(pid, _, _, _, _, _, _, _, _, _) (\(pid, _, _, _, _, _, _, _, _, _)
@ -180,8 +178,8 @@ produceProductOverviews refine =
-- <<< arr (\_ -> (selectTable productTable, selectTable amountTable)) -< () -- <<< arr (\_ -> (selectTable productTable, selectTable amountTable)) -< ()
restrict -< case refine of restrict -< case refine of
AllProducts -> toFields True AllProducts -> toFields True
AvailableProducts -> a3 ./= (toFields (0 :: Int) :: Column PGInt4) AvailableProducts -> a3 ./= (toFields (0 :: Int) :: Column SqlInt4)
DepletedProducts -> a3 .== (toFields (0 :: Int) :: Column PGInt4) DepletedProducts -> a3 .== (toFields (0 :: Int) :: Column SqlInt4)
returnA -< (p, i2, i6, i6a, i7, i8, i9, i11, i12, i13, a3, a4) returnA -< (p, i2, i6, i6a, i7, i8, i9, i11, i12, i13, a3, a4)
queryAmounts queryAmounts

33
src/Model/Role.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Arrows #-}
module Model.Role where module Model.Role where
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
@ -13,7 +14,7 @@ import Data.Int (Int64)
import Opaleye as O hiding (null, not) import Opaleye as O hiding (null, not)
import Control.Arrow ((<<<)) import Control.Arrow
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -173,10 +174,10 @@ selectRoleList
-> PGS.Connection -> PGS.Connection
-> MateHandler [Role] -> MateHandler [Role]
selectRoleList ids conn = do selectRoleList ids conn = do
liftIO $ map fromDatabase <$> runSelect conn ( liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do
keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> stuff@(id_, _, _, _, _, _, _, _, _, _, _, _) <- selectTable roleTable -< ()
in_ (map toFields ids) id_) restrict -< in_ (map toFields ids) id_
<<< selectTable roleTable returnA -< stuff
) :: MateHandler [Role] ) :: MateHandler [Role]
insertRole insertRole
@ -222,9 +223,10 @@ queryRoleIdByName
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> MateHandler Int
queryRoleIdByName name conn = do queryRoleIdByName name conn = do
liftIO $ roleID . fromDatabase . head <$> runSelect conn ( liftIO $ roleID . fromDatabase . head <$> runSelect conn ( proc () -> do
keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _) -> stuff@(_, rname, _, _, _, _, _, _, _, _, _, _) <- selectTable roleTable -< ()
toFields name .== rname) <<< selectTable roleTable restrict -< toFields name .== rname
returnA -< stuff
) :: MateHandler Int ) :: MateHandler Int
queryRoleIdByCapabilities queryRoleIdByCapabilities
@ -233,8 +235,9 @@ queryRoleIdByCapabilities
-> MateHandler Int -> MateHandler Int
queryRoleIdByCapabilities (pa1, pa2, pa3, pa4, pa5, pa6, pa7, pa8, pa9, pa10) conn = queryRoleIdByCapabilities (pa1, pa2, pa3, pa4, pa5, pa6, pa7, pa8, pa9, pa10) conn =
do do
liftIO $ roleID . fromDatabase . head <$> runSelect conn ( liftIO $ roleID . fromDatabase . head <$> runSelect conn ( proc () -> do
keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) -> stuff@(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) <- selectTable roleTable -< ()
restrict -<
toFields pa1 .== c1 .&& toFields pa1 .== c1 .&&
toFields pa2 .== c2 .&& toFields pa2 .== c2 .&&
toFields pa3 .== c3 .&& toFields pa3 .== c3 .&&
@ -245,8 +248,7 @@ queryRoleIdByCapabilities (pa1, pa2, pa3, pa4, pa5, pa6, pa7, pa8, pa9, pa10) co
toFields pa8 .== c8 .&& toFields pa8 .== c8 .&&
toFields pa9 .== c9 .&& toFields pa9 .== c9 .&&
toFields pa10 .== c10 toFields pa10 .== c10
) returnA -< stuff
<<< selectTable roleTable
) :: MateHandler Int ) :: MateHandler Int
@ -272,9 +274,10 @@ selectUserAssociations
-> PGS.Connection -> PGS.Connection
-> MateHandler [RoleAssociation] -> MateHandler [RoleAssociation]
selectUserAssociations uid conn = do selectUserAssociations uid conn = do
rawAssocs <- liftIO $ runSelect conn( rawAssocs <- liftIO $ runSelect conn( proc () -> do
keepWhen (\(auid, _) -> auid .== toFields uid) stuff@(auid, _) <- selectTable userToRoleTable -< ()
<<< selectTable userToRoleTable restrict -< auid .== toFields uid
returnA -< stuff
) :: MateHandler ) :: MateHandler
[ [
( Int ( Int