diff --git a/src/Classes/FromDatabase.hs b/src/Classes/FromDatabase.hs index 767095e..8975799 100644 --- a/src/Classes/FromDatabase.hs +++ b/src/Classes/FromDatabase.hs @@ -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 diff --git a/src/Classes/ToDatabase.hs b/src/Classes/ToDatabase.hs index 145f64c..1e7e229 100644 --- a/src/Classes/ToDatabase.hs +++ b/src/Classes/ToDatabase.hs @@ -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 diff --git a/src/Model/Amount.hs b/src/Model/Amount.hs index 94186a2..0d490cd 100644 --- a/src/Model/Amount.hs +++ b/src/Model/Amount.hs @@ -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 diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index a8a291f..7134c43 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -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 diff --git a/src/Model/Avatar.hs b/src/Model/Avatar.hs index 9e4f80e..59da2a5 100644 --- a/src/Model/Avatar.hs +++ b/src/Model/Avatar.hs @@ -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 diff --git a/src/Model/Journal.hs b/src/Model/Journal.hs index b7574e3..0434725 100644 --- a/src/Model/Journal.hs +++ b/src/Model/Journal.hs @@ -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 diff --git a/src/Model/Product.hs b/src/Model/Product.hs index a065e29..d75d0b5 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -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 diff --git a/src/Model/Role.hs b/src/Model/Role.hs index d2a0ea9..ce7048f 100644 --- a/src/Model/Role.hs +++ b/src/Model/Role.hs @@ -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