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 #-}
module Classes.FromDatabase where
import Data.Kind (Type)
class FromDatabase a where
type OutTuple a :: *
type OutTuple a :: Type
fromDatabase :: OutTuple a -> a

4
src/Classes/ToDatabase.hs
View file

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

65
src/Model/Amount.hs
View file

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

25
src/Model/Auth.hs
View file

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

8
src/Model/Avatar.hs
View file

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

8
src/Model/Journal.hs
View file

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

62
src/Model/Product.hs
View file

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

33
src/Model/Role.hs
View file

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