linted
This commit is contained in:
parent
9358d21752
commit
89961301d7
11 changed files with 275 additions and 230 deletions
|
|
@ -1,15 +1,22 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Control.Buy where
|
||||
|
||||
import Control.Monad (void, foldM)
|
||||
import Control.Monad (void, foldM, unless)
|
||||
|
||||
import Control.Monad.Reader (asks)
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Text.Printf (printf)
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Control.User
|
||||
import Types
|
||||
import Model
|
||||
import Util
|
||||
|
||||
buy
|
||||
:: Maybe (Int, AuthMethod)
|
||||
|
|
@ -68,3 +75,41 @@ buy auth pds = do
|
|||
return $ PurchaseResult
|
||||
(PayAmount price)
|
||||
missing
|
||||
|
||||
amountUpdate
|
||||
:: [PurchaseDetail]
|
||||
-> MateHandler ()
|
||||
amountUpdate details = do
|
||||
conn <- asks rsConnection
|
||||
notify <- foldM (\acc pd@(PurchaseDetail pid _) -> do
|
||||
void $ postBuyProductAmountUpdate pd conn
|
||||
newAmout <- getLatestAmountByProductId pid conn
|
||||
minAmout <- productMinAmount . fromJust <$> productSelectSingle pid conn
|
||||
if newAmout < minAmout
|
||||
then return (pid : acc)
|
||||
else return acc
|
||||
)
|
||||
[]
|
||||
details
|
||||
unless (null notify) $
|
||||
do
|
||||
messageText <- T.pack . mconcat . map (<> "\n") . (\insert ->
|
||||
[ printf (__ "Hello,")
|
||||
, ""
|
||||
, printf (__ "Following products are low on stock:")
|
||||
]
|
||||
++
|
||||
insert
|
||||
++
|
||||
[ ""
|
||||
, __ "Please consider ordering and refilling those products."
|
||||
, __ "\nSincerely,\nMateamt"
|
||||
]) <$>
|
||||
mapM
|
||||
(\pid -> do
|
||||
name <- productIdent . fromJust <$> productSelectSingle pid conn
|
||||
amount <- getLatestAmountByProductId pid conn
|
||||
return (printf (__ "%s (Amout remaining: %d)") name amount)
|
||||
)
|
||||
notify
|
||||
sendAdminNotification (__ "Low sotck alert") messageText
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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_)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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_)
|
||||
|
|
|
|||
|
|
@ -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_)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -35,7 +35,7 @@ data PurchaseResultFlag
|
|||
= PurchaseOK
|
||||
| PurchaseDebtful
|
||||
| PayAmount Int
|
||||
deriving (Generic, Show)
|
||||
deriving (Generic, Show, Eq)
|
||||
|
||||
instance ToJSON PurchaseResultFlag where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
|
|
|||
|
|
@ -82,6 +82,14 @@ sendUserNotification recipient subject message =
|
|||
Nothing ->
|
||||
return ()
|
||||
|
||||
sendAdminNotification
|
||||
:: T.Text -- The mail subject
|
||||
-> T.Text -- The mail body
|
||||
-> MateHandler ()
|
||||
sendAdminNotification subject message =
|
||||
-- TODO: Grab administrators from settings and actually send the mails to them
|
||||
return ()
|
||||
|
||||
sendNotification mail = do
|
||||
sendmail <- asks rsSendmailPath
|
||||
liftIO $ do
|
||||
|
|
|
|||
Loading…
Reference in a new issue