This commit is contained in:
nek0 2021-07-14 03:08:58 +02:00
parent 9358d21752
commit 9d05c4cf23
9 changed files with 221 additions and 229 deletions

View File

@ -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."
}

View File

@ -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_)

View File

@ -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
}

View File

@ -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
}

View File

@ -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_)

View File

@ -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_)

View File

@ -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
}

View File

@ -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
}

View File

@ -35,7 +35,7 @@ data PurchaseResultFlag
= PurchaseOK
| PurchaseDebtful
| PayAmount Int
deriving (Generic, Show)
deriving (Generic, Show, Eq)
instance ToJSON PurchaseResultFlag where
toEncoding = genericToEncoding defaultOptions