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

linted

Browse source
This commit is contained in:
nek0 2021-07-14 03:08:58 +02:00
parent 9358d21752
commit 89961301d7
11 changed files with 275 additions and 230 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

47
src/Control/Buy.hs
View file

@ -1,15 +1,22 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Control.Buy where module Control.Buy where
import Control.Monad (void, foldM) import Control.Monad (void, foldM, unless)
import Control.Monad.Reader (asks) import Control.Monad.Reader (asks)
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Text.Printf (printf)
-- internal imports -- internal imports
import Control.User import Control.User
import Types import Types
import Model import Model
import Util
buy buy
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
@ -68,3 +75,41 @@ buy auth pds = do
return $ PurchaseResult return $ PurchaseResult
(PayAmount price) (PayAmount price)
missing 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

34
src/Control/User.hs
View file

@ -150,7 +150,7 @@ userNotify
-> [PurchaseDetail] -> [PurchaseDetail]
-> PurchaseResult -> PurchaseResult
-> MateHandler () -> MateHandler ()
userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do
conn <- asks rsConnection conn <- asks rsConnection
authOV <- selectAuthOverviewById auid conn authOV <- selectAuthOverviewById auid conn
userDetails <- userDetailsSelect (authOverviewUser authOV) conn userDetails <- userDetailsSelect (authOverviewUser authOV) conn
@ -166,7 +166,7 @@ userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do
boughtItems boughtItems
currencyFrac <- asks rsCurrencyFraction currencyFrac <- asks rsCurrencyFraction
currencySymb <- asks rsCurrencySymbol currencySymb <- asks rsCurrencySymbol
let messageText = T.pack $ mconcat $ map (<> ("\n")) $ let messageText = T.pack $ mconcat $ map (<> "\n") $
[ printf (__ "Hello %s,") (userDetailsIdent userDetails) [ printf (__ "Hello %s,") (userDetailsIdent userDetails)
, "" , ""
, printf (__ "Your authentication key with the comment \"%s\"\ , printf (__ "Your authentication key with the comment \"%s\"\
@ -174,38 +174,39 @@ userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do
(authOverviewComment authOV) (authOverviewComment authOV)
, "" , ""
] ++ ] ++
( map map
(\(amount, ident, price) -> (\(amount, ident, price) ->
printf printf
("%dx %s " <> ("%dx %s " <>
(__ "for the price of") <> __ "for the price of" <>
"%d %f." <> "%d %f." <>
(printf "%d" currencyFrac) <> printf "%d" currencyFrac <>
(printf "%s" currencySymb) printf "%s" currencySymb
) )
amount amount
ident ident
price price
) )
digestedDetails digestedDetails
)
++ ++
[ "" [ ""
, printf (__ "For a total price of %s%s") <> , printf (__ "For a total price of %s%s") <>
(printf printf
("%f." <> ("%f." <>
(printf "%d" currencyFrac :: String)) (printf "%d" currencyFrac :: String))
((fromIntegral $ (fromIntegral (
foldl (\acc (_, _, p) -> acc + p) foldl (\acc (_, _, p) -> acc + p)
0 0
digestedDetails digestedDetails
) / ) /
(fromIntegral $ 10 ^ currencyFrac) fromIntegral (10 ^ currencyFrac :: Int)
:: Float )) :: Float )
currencySymb 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 case userDetailsEmail userDetails of
Just _ -> do Just _ -> do
sendUserNotification sendUserNotification
@ -214,6 +215,7 @@ userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do
messageText messageText
Nothing -> Nothing ->
return () return ()
-- throwError $ err501 userNotify Nothing _ _ =
-- { errBody = "userNotify: Not implemented yet" throwError $ err401
-- } { errBody = "No Authentication present."
}

53
src/Model/Amount.hs
View file

@ -13,7 +13,6 @@ import Control.Arrow ((<<<))
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Opaleye as O import Opaleye as O
import Opaleye.Constant as C
-- internal imports -- internal imports
@ -67,11 +66,11 @@ insertNewEmptyAmount bevid (ProductSubmit _ price _ _ _ _ _ _ _ _) conn =
{ iTable = amountTable { iTable = amountTable
, iRows = , iRows =
[ [
( C.constant bevid ( toFields bevid
, C.constant now , toFields now
, C.constant (0 :: Int) , toFields (0 :: Int)
, C.constant price , toFields price
, C.constant False , toFields False
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_) , iReturning = rReturning (\(id_, _, _, _, _) -> id_)
@ -85,8 +84,8 @@ getLatestPriceByProductId
getLatestPriceByProductId pid conn = do getLatestPriceByProductId pid conn = do
liftIO $ amountPrice . fromDatabase . head <$> runSelect conn ( liftIO $ amountPrice . fromDatabase . head <$> runSelect conn (
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts))
(keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) (keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid)
<<< queryTable amountTable) <<< selectTable amountTable)
) )
getLatestAmountByProductId getLatestAmountByProductId
@ -96,8 +95,8 @@ getLatestAmountByProductId
getLatestAmountByProductId pid conn = do getLatestAmountByProductId pid conn = do
liftIO $ amountAmount . fromDatabase . head <$> runSelect conn ( liftIO $ amountAmount . fromDatabase . head <$> runSelect conn (
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts))
(keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) (keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid)
<<< queryTable amountTable) <<< selectTable amountTable)
) )
getLatestTotalPrice getLatestTotalPrice
@ -108,8 +107,8 @@ getLatestTotalPrice (PurchaseDetail pid amount) conn = do
liftIO $ (amount *) . amountPrice . fromDatabase . head <$> liftIO $ (amount *) . amountPrice . fromDatabase . head <$>
runSelect conn ( runSelect conn (
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $ limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) <<<
queryTable amountTable selectTable amountTable
) )
checkProductAvailability checkProductAvailability
@ -118,10 +117,10 @@ 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 $ limit 1 $
orderBy (desc (\(_, ts, _, _, _) -> ts)) $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) <<<
queryTable amountTable selectTable amountTable
) )
if realamount < amount if realamount < amount
then return (Just $ amount - realamount) then return (Just $ amount - realamount)
@ -142,11 +141,11 @@ manualProductAmountUpdate aups conn =
{ iTable = amountTable { iTable = amountTable
, iRows = , iRows =
[ [
( C.constant pid ( toFields pid
, C.constant now , toFields now
, C.constant amount , toFields amount
, C.constant oldprice , toFields oldprice
, C.constant True , toFields True
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_) , iReturning = rReturning (\(id_, _, _, _, _) -> id_)
@ -167,8 +166,8 @@ postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do
(\am -> (amountAmount am, amountPrice am)) . fromDatabase . head <$> ( (\am -> (amountAmount am, amountPrice am)) . fromDatabase . head <$> (
liftIO $ runSelect conn $ limit 1 $ liftIO $ runSelect conn $ limit 1 $
orderBy (desc (\(_, ts, _, _, _) -> ts)) $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< keepWhen (\(id_, _, _, _, _) -> id_ .== toFields pid) <<<
queryTable amountTable selectTable amountTable
:: MateHandler :: MateHandler
[ ( Int [ ( Int
, UTCTime , UTCTime
@ -182,11 +181,11 @@ postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do
{ iTable = amountTable { iTable = amountTable
, iRows = , iRows =
[ [
( C.constant pid ( toFields pid
, C.constant now , toFields now
, C.constant (amount - pdamount) , toFields (amount - pdamount)
, C.constant oldprice , toFields oldprice
, C.constant False , toFields False
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_) , iReturning = rReturning (\(id_, _, _, _, _) -> id_)

49
src/Model/Auth.hs
View file

@ -33,7 +33,6 @@ import Data.ByteString.Random
import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64 as B64
import Opaleye hiding (null) import Opaleye hiding (null)
import qualified Opaleye.Constant as C
-- internal imports -- internal imports
@ -123,8 +122,8 @@ selectAuthOverviews
selectAuthOverviews uid conn = do selectAuthOverviews uid conn = do
liftIO $ map fromDatabase <$> runSelect conn (proc () -> do liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
(adid, aduid, admethod, adcomment, _) <- (adid, aduid, admethod, adcomment, _) <-
queryTable authDataTable -< () selectTable authDataTable -< ()
restrict -< aduid .== C.constant uid restrict -< aduid .== toFields uid
returnA -< (adid, aduid, adcomment, admethod) returnA -< (adid, aduid, adcomment, admethod)
) )
@ -134,10 +133,10 @@ selectAuthOverviewById
-> PGS.Connection -- ^ Connection Handler -> PGS.Connection -- ^ Connection Handler
-> MateHandler AuthOverview -> MateHandler AuthOverview
selectAuthOverviewById aid conn = do 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, _) <- (adid, aduid, admethod, adcomment, _) <-
queryTable authDataTable -< () selectTable authDataTable -< ()
restrict -< adid .== C.constant aid restrict -< adid .== toFields aid
returnA -< (adid, aduid, adcomment, admethod) returnA -< (adid, aduid, adcomment, admethod)
) )
@ -153,9 +152,9 @@ getUserAuthInfo uid method conn = do
void $ threadDelay delayTime void $ threadDelay delayTime
map fromDatabase <$> runSelect conn (proc () -> do map fromDatabase <$> runSelect conn (proc () -> do
(aid, auid, amethod, acomment, apayload) <- (aid, auid, amethod, acomment, apayload) <-
queryTable authDataTable -< () selectTable authDataTable -< ()
restrict -< restrict -<
auid .== C.constant uid .&& amethod .== C.constant (fromEnum method) auid .== toFields uid .&& amethod .== toFields (fromEnum method)
returnA -< (aid, auid, amethod, acomment, apayload) returnA -< (aid, auid, amethod, acomment, apayload)
) :: IO [AuthData] ) :: IO [AuthData]
if null authdata if null authdata
@ -183,11 +182,11 @@ putUserAuthInfo uid method comment payload conn =
{ iTable = authDataTable { iTable = authDataTable
, iRows = , iRows =
[ [
( C.constant (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, C.constant uid , toFields uid
, C.constant (fromEnum method) , toFields (fromEnum method)
, C.constant comment , toFields comment
, C.constant (either error id $ B64.decode $ encodeUtf8 payload) , toFields (either error id $ B64.decode $ encodeUtf8 payload)
) )
] ]
, iReturning = rReturning (\(adid, _, _, _, _) -> adid) , iReturning = rReturning (\(adid, _, _, _, _) -> adid)
@ -201,7 +200,7 @@ deleteAuthDataById
-> MateHandler Int64 -> MateHandler Int64
deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete deleteAuthDataById adid conn = liftIO $ runDelete_ conn $ Delete
{ dTable = authDataTable { dTable = authDataTable
, dWhere = \(aid, _, _, _, _) -> aid .== C.constant adid , dWhere = \(aid, _, _, _, _) -> aid .== toFields adid
, dReturning = rCount , dReturning = rCount
} }
@ -213,10 +212,10 @@ validateToken
validateToken header conn = do validateToken header conn = do
tokens <- liftIO $ map fromDatabase <$> runSelect conn ( tokens <- liftIO $ map fromDatabase <$> runSelect conn (
keepWhen (\(tstr, _, _, _) -> keepWhen (\(tstr, _, _, _) ->
tstr .== C.constant (decodeUtf8 header)) <<< queryTable tokenTable tstr .== toFields (decodeUtf8 header)) <<< selectTable tokenTable
) )
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)
@ -241,8 +240,8 @@ generateToken
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, _, _) -> keepWhen (\(_, auid, amethod, _, _) ->
auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method)) auid .== toFields tuid .&& amethod .== toFields (fromEnum method))
<<< queryTable authDataTable <<< selectTable authDataTable
) :: MateHandler [AuthData] ) :: MateHandler [AuthData]
let userPayloads = map let userPayloads = map
authDataPayload authDataPayload
@ -279,10 +278,10 @@ insertToken (Token tString tUser tExpiry tMethod) conn =
{ iTable = tokenTable { iTable = tokenTable
, iRows = , iRows =
[ [
( C.constant tString ( toFields tString
, C.constant tUser , toFields tUser
, C.constant tExpiry , toFields tExpiry
, C.constant (fromEnum tMethod) , toFields (fromEnum tMethod)
) )
] ]
, iReturning = rReturning (\(ident, _, _, _) -> ident) , iReturning = rReturning (\(ident, _, _, _) -> ident)
@ -297,7 +296,7 @@ deleteToken
deleteToken tstr conn = deleteToken tstr conn =
liftIO $ runDelete_ conn $ Delete liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable { dTable = tokenTable
, dWhere = \(rtstr, _, _, _) -> rtstr .== C.constant tstr , dWhere = \(rtstr, _, _, _) -> rtstr .== toFields tstr
, dReturning = rCount , dReturning = rCount
} }
@ -308,7 +307,7 @@ deleteTokenByUserId
-> MateHandler Int64 -> MateHandler Int64
deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable { dTable = tokenTable
, dWhere = \(_, rid, _, _) -> rid .== C.constant uid , dWhere = \(_, rid, _, _) -> rid .== toFields uid
, dReturning = rCount , dReturning = rCount
} }
@ -319,7 +318,7 @@ deleteOldTokens
-> IO Int64 -> IO Int64
deleteOldTokens now conn = runDelete_ conn $ Delete deleteOldTokens now conn = runDelete_ conn $ Delete
{ dTable = tokenTable { dTable = tokenTable
, dWhere = \(_, _, expiry, _) -> expiry .< C.constant now , dWhere = \(_, _, expiry, _) -> expiry .< toFields now
, dReturning = rCount , dReturning = rCount
} }

23
src/Model/Avatar.hs
View file

@ -21,7 +21,6 @@ import Control.Arrow
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Opaleye as O import Opaleye as O
import Opaleye.Constant as C
-- internal imports -- internal imports
@ -64,7 +63,7 @@ avatarSelect conn = liftIO $ do
avatars <- runSelect conn ( avatars <- runSelect conn (
proc () -> do proc () -> do
ret <- orderBy (desc (\(_, name, _, _) -> name)) ret <- orderBy (desc (\(_, name, _, _) -> name))
(queryTable avatarTable) -< () (selectTable avatarTable) -< ()
returnA -< ret returnA -< ret
) )
:: IO :: IO
@ -86,8 +85,8 @@ avatarSelectById
-> IO [Avatar] -> IO [Avatar]
avatarSelectById aid conn = do avatarSelectById aid conn = do
avatars <- runSelect conn ( avatars <- runSelect conn (
keepWhen (\(aaid, _, _, _) -> aaid .== C.constant aid) keepWhen (\(aaid, _, _, _) -> aaid .== toFields aid)
<<< queryTable avatarTable) <<< selectTable avatarTable)
:: IO :: IO
[ ( Int [ ( Int
, T.Text , T.Text
@ -111,10 +110,10 @@ insertAvatar (AvatarData name dat) conn = fmap head $ liftIO $ do
{ iTable = avatarTable { iTable = avatarTable
, iRows = , iRows =
[ [
( C.constant (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, C.constant name , toFields name
, C.constant hash , toFields hash
, C.constant (encodeUtf8 dat) , toFields (encodeUtf8 dat)
) )
] ]
, iReturning = rReturning (\(aid, _, _, _) -> aid) , iReturning = rReturning (\(aid, _, _, _) -> aid)
@ -132,11 +131,11 @@ updateAvatar aid (AvatarData name dat) conn = liftIO $ do
{ uTable = avatarTable { uTable = avatarTable
, uUpdateWith = updateEasy (\(did, _, _, _) -> , uUpdateWith = updateEasy (\(did, _, _, _) ->
( did ( did
, C.constant name , toFields name
, C.constant hash , toFields hash
, C.constant (encodeUtf8 dat) , toFields (encodeUtf8 dat)
) )
) )
, uWhere = \(did, _, _, _) -> did .== C.constant aid , uWhere = \(did, _, _, _) -> did .== toFields aid
, uReturning = rCount , uReturning = rCount
} }

28
src/Model/Journal.hs
View file

@ -5,11 +5,8 @@ module Model.Journal where
import Data.Maybe import Data.Maybe
import Data.Time (UTCTime)
import Data.Time.Clock import Data.Time.Clock
import qualified Data.Text as T
import Data.Profunctor.Product (p5) import Data.Profunctor.Product (p5)
import qualified Database.PostgreSQL.Simple as PGS import qualified Database.PostgreSQL.Simple as PGS
@ -17,7 +14,6 @@ import qualified Database.PostgreSQL.Simple as PGS
import Control.Arrow import Control.Arrow
import Opaleye as O hiding (null, not) import Opaleye as O hiding (null, not)
import Opaleye.Constant as C
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -78,7 +74,7 @@ selectJournalEntries mlimit moffset conn = liftIO $ do
entries <- runSelect conn entries <- runSelect conn
( proc () -> do ( proc () -> do
ret <- lim $ off $ orderBy (desc (\(id_, _, _, _, _) -> id_)) ret <- lim $ off $ orderBy (desc (\(id_, _, _, _, _) -> id_))
(queryTable journalTable) -< () (selectTable journalTable) -< ()
returnA -< ret returnA -< ret
) :: IO ) :: IO
[ ( Int [ ( Int
@ -109,7 +105,7 @@ selectLatestJournalEntry conn = liftIO $ do
lastTwoEntries <- runSelect conn lastTwoEntries <- runSelect conn
( proc () -> do ( proc () -> do
ret <- limit 2 (orderBy (desc (\(id_, _, _, _, _) -> id_)) ret <- limit 2 (orderBy (desc (\(id_, _, _, _, _) -> id_))
(queryTable journalTable)) -< () (selectTable journalTable)) -< ()
returnA -< ret returnA -< ret
) :: IO ) :: IO
[ ( Int [ ( Int
@ -143,11 +139,11 @@ insertNewJournalEntry (JournalSubmit user action amount) conn = do
{ iTable = journalTable { iTable = journalTable
, iRows = , iRows =
[ [
( C.constant (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, C.constant now , toFields now
, C.constant user , toFields user
, C.constant (fromEnum action) , toFields (fromEnum action)
, C.constant (lastTotal + amount) , toFields (lastTotal + amount)
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_) , iReturning = rReturning (\(id_, _, _, _, _) -> id_)
@ -169,11 +165,11 @@ insertNewCashCheck (JournalCashCheck user amount) conn =
{ iTable = journalTable { iTable = journalTable
, iRows = , iRows =
[ [
( C.constant (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, C.constant now , toFields now
, C.constant (Just user) , toFields (Just user)
, C.constant (fromEnum CashCheck) , toFields (fromEnum CashCheck)
, C.constant amount , toFields amount
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_) , iReturning = rReturning (\(id_, _, _, _, _) -> id_)

71
src/Model/Product.hs
View file

@ -22,7 +22,6 @@ import qualified Database.PostgreSQL.Simple as PGS
import qualified Data.Profunctor as P import qualified Data.Profunctor as P
import Opaleye as O import Opaleye as O
import Opaleye.Constant as C
-- internal imports -- internal imports
@ -90,7 +89,7 @@ productSelect
-> MateHandler [Product] -> MateHandler [Product]
productSelect conn = do productSelect conn = do
liftIO $ map fromDatabase <$> runSelect conn liftIO $ map fromDatabase <$> runSelect conn
(queryTable productTable) (selectTable productTable)
productSelectSingle productSelectSingle
@ -101,8 +100,8 @@ productSelectSingle pid conn = do
prods <- liftIO $ map fromDatabase <$> runSelect conn prods <- liftIO $ map fromDatabase <$> runSelect conn
( limit 1 ( limit 1
(keepWhen ( (keepWhen (
\(id_, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid \(id_, _, _, _, _, _, _, _, _, _) -> id_ .== toFields pid
) <<< queryTable productTable) ) <<< selectTable productTable)
) )
case prods of case prods of
p:_ -> return (Just p) p:_ -> return (Just p)
@ -144,18 +143,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
( C.constant (0 :: Int) :: Column PGInt4 ( toFields (0 :: Int) :: Column PGInt4
, C.constant ("ERROR PRODUCT" :: T.Text) :: Column PGText , toFields ("ERROR PRODUCT" :: T.Text) :: Column PGText
, C.constant (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column PGInt4
, C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4) , toFields (Just (0 :: Int)) :: Column (Nullable PGInt4)
, C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4) , toFields (Just (0 :: Int)) :: Column (Nullable PGInt4)
, C.constant (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column PGInt4
, C.constant (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column PGInt4
, C.constant (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column PGInt4
, C.constant (Just (0 :: Int)) :: Column (Nullable PGInt4) , toFields (Just (0 :: Int)) :: Column (Nullable PGInt4)
, C.constant (Just ("" :: T.Text)) :: Column (Nullable PGText) , toFields (Just ("" :: T.Text)) :: Column (Nullable PGText)
, C.constant (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column PGInt4
, C.constant (0 :: Int) :: Column PGInt4 , toFields (0 :: Int) :: Column PGInt4
) )
) )
(\(pid, _, _, _, _, _, _, _, _, _) (\(pid, _, _, _, _, _, _, _, _, _)
@ -180,9 +179,9 @@ produceProductOverviews refine =
)) -< () )) -< ()
-- <<< arr (\_ -> (selectTable productTable, selectTable amountTable)) -< () -- <<< arr (\_ -> (selectTable productTable, selectTable amountTable)) -< ()
restrict -< case refine of restrict -< case refine of
AllProducts -> C.constant True AllProducts -> toFields True
AvailableProducts -> a3 ./= (C.constant (0 :: Int) :: Column PGInt4) AvailableProducts -> a3 ./= (toFields (0 :: Int) :: Column PGInt4)
DepletedProducts -> a3 .== (C.constant (0 :: Int) :: Column PGInt4) DepletedProducts -> a3 .== (toFields (0 :: Int) :: Column PGInt4)
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
@ -191,8 +190,8 @@ queryAmounts
-> IO [Amount] -> IO [Amount]
queryAmounts conn pid = map fromDatabase <$> runSelect conn (proc () -> do queryAmounts conn pid = map fromDatabase <$> runSelect conn (proc () -> do
stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts)) stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
(queryTable amountTable) -< () (selectTable amountTable) -< ()
restrict -< C.constant pid .== a1 restrict -< toFields pid .== a1
returnA -< stuff returnA -< stuff
) )
@ -281,16 +280,16 @@ insertProduct (ProductSubmit ident _ ml ava sup maxi mini apc ppc artnr) conn =
{ iTable = productTable { iTable = productTable
, iRows = , iRows =
[ [
( C.constant (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, C.constant ident , toFields ident
, C.constant ml , toFields ml
, C.constant ava , toFields ava
, C.constant sup , toFields sup
, C.constant maxi , toFields maxi
, C.constant mini , toFields mini
, C.constant apc , toFields apc
, C.constant ppc , toFields ppc
, C.constant artnr , toFields artnr
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _) -> id_) , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _) -> id_)
@ -314,11 +313,11 @@ manualProductAmountRefill aups conn =
{ iTable = amountTable { iTable = amountTable
, iRows = , iRows =
[ [
( C.constant pid ( toFields pid
, C.constant now , toFields now
, C.constant (oldamount + (amountSingles + (perCrate * amountCrates))) , toFields (oldamount + (amountSingles + (perCrate * amountCrates)))
, C.constant oldprice , toFields oldprice
, C.constant False , toFields False
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_) , iReturning = rReturning (\(id_, _, _, _, _) -> id_)

145
src/Model/Role.hs
View file

@ -12,7 +12,6 @@ import qualified Data.Text as T
import Data.Int (Int64) import Data.Int (Int64)
import Opaleye as O hiding (null, not) import Opaleye as O hiding (null, not)
import Opaleye.Constant as C
import Control.Arrow ((<<<)) import Control.Arrow ((<<<))
@ -121,18 +120,18 @@ runInsertInitialRoles conn = do
{ iTable = roleTable { iTable = roleTable
, iRows = , iRows =
[ [
( C.constant (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, C.constant ("Administrator" :: String) , toFields ("Administrator" :: String)
, C.constant True , toFields True
, C.constant True , toFields True
, C.constant True , toFields True
, C.constant True , toFields True
, C.constant True , toFields True
, C.constant True , toFields True
, C.constant True , toFields True
, C.constant True , toFields True
, C.constant True , toFields True
, C.constant True , toFields True
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
@ -142,18 +141,18 @@ runInsertInitialRoles conn = do
{ iTable = roleTable { iTable = roleTable
, iRows = , iRows =
[ [
( C.constant (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, C.constant ("User" :: String) , toFields ("User" :: String)
, C.constant False , toFields False
, C.constant False , toFields False
, C.constant False , toFields False
, C.constant False , toFields False
, C.constant False , toFields False
, C.constant False , toFields False
, C.constant False , toFields False
, C.constant False , toFields False
, C.constant False , toFields False
, C.constant False , toFields False
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
@ -166,7 +165,7 @@ selectAllRoles
-> MateHandler [Role] -> MateHandler [Role]
selectAllRoles conn = do selectAllRoles conn = do
liftIO $ map fromDatabase <$> runSelect conn ( liftIO $ map fromDatabase <$> runSelect conn (
queryTable roleTable selectTable roleTable
) :: MateHandler [Role] ) :: MateHandler [Role]
selectRoleList selectRoleList
@ -176,8 +175,8 @@ selectRoleList
selectRoleList ids conn = do selectRoleList ids conn = do
liftIO $ map fromDatabase <$> runSelect conn ( liftIO $ map fromDatabase <$> runSelect conn (
keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> keepWhen (\(id_, _, _, _, _, _, _, _, _, _, _, _) ->
in_ (map C.constant ids) id_) in_ (map toFields ids) id_)
<<< queryTable roleTable <<< selectTable roleTable
) :: MateHandler [Role] ) :: MateHandler [Role]
insertRole insertRole
@ -199,18 +198,18 @@ insertRole name c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 conn = do
{ iTable = roleTable { iTable = roleTable
, iRows = , iRows =
[ [
( C.constant (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, C.constant name , toFields name
, C.constant c1 , toFields c1
, C.constant c2 , toFields c2
, C.constant c3 , toFields c3
, C.constant c4 , toFields c4
, C.constant c5 , toFields c5
, C.constant c6 , toFields c6
, C.constant c7 , toFields c7
, C.constant c8 , toFields c8
, C.constant c9 , toFields c9
, C.constant c10 , toFields c10
) )
] ]
, iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ ) , iReturning = rReturning (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ )
@ -225,29 +224,29 @@ queryRoleIdByName
queryRoleIdByName name conn = do queryRoleIdByName name conn = do
liftIO $ roleID . fromDatabase . head <$> runSelect conn ( liftIO $ roleID . fromDatabase . head <$> runSelect conn (
keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _) -> keepWhen (\(_, rname, _, _, _, _, _, _, _, _, _, _) ->
C.constant name .== rname) <<< queryTable roleTable toFields name .== rname) <<< selectTable roleTable
) :: MateHandler Int ) :: MateHandler Int
queryRoleIdByCapabilities queryRoleIdByCapabilities
:: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool) :: (Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool, Bool)
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> 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 do
liftIO $ roleID . fromDatabase . head <$> runSelect conn ( liftIO $ roleID . fromDatabase . head <$> runSelect conn (
keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) -> keepWhen (\(_, _, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10) ->
C.constant p1 .== c1 .&& toFields pa1 .== c1 .&&
C.constant p2 .== c2 .&& toFields pa2 .== c2 .&&
C.constant p3 .== c3 .&& toFields pa3 .== c3 .&&
C.constant p4 .== c4 .&& toFields pa4 .== c4 .&&
C.constant p5 .== c5 .&& toFields pa5 .== c5 .&&
C.constant p6 .== c6 .&& toFields pa6 .== c6 .&&
C.constant p7 .== c7 .&& toFields pa7 .== c7 .&&
C.constant p8 .== c8 .&& toFields pa8 .== c8 .&&
C.constant p9 .== c9 .&& toFields pa9 .== c9 .&&
C.constant p10 .== c10 toFields pa10 .== c10
) )
<<< queryTable roleTable <<< selectTable roleTable
) :: MateHandler Int ) :: MateHandler Int
@ -256,7 +255,7 @@ selectAllRoleAssociations
-> MateHandler [RoleAssociation] -> MateHandler [RoleAssociation]
selectAllRoleAssociations conn = do selectAllRoleAssociations conn = do
rawRoleAssocs <- liftIO $ runSelect conn ( rawRoleAssocs <- liftIO $ runSelect conn (
queryTable userToRoleTable selectTable userToRoleTable
) :: MateHandler ) :: MateHandler
[ [
( Int ( Int
@ -274,8 +273,8 @@ selectUserAssociations
-> MateHandler [RoleAssociation] -> MateHandler [RoleAssociation]
selectUserAssociations uid conn = do selectUserAssociations uid conn = do
rawAssocs <- liftIO $ runSelect conn( rawAssocs <- liftIO $ runSelect conn(
keepWhen (\(auid, _) -> auid .== C.constant uid) keepWhen (\(auid, _) -> auid .== toFields uid)
<<< queryTable userToRoleTable <<< selectTable userToRoleTable
) :: MateHandler ) :: MateHandler
[ [
( Int ( Int
@ -295,8 +294,8 @@ associateUserToRole uid rid conn =
{ iTable = userToRoleTable { iTable = userToRoleTable
, iRows = , iRows =
[ [
( C.constant uid ( toFields uid
, C.constant rid , toFields rid
) )
] ]
, iReturning = rReturning (const ()) , iReturning = rReturning (const ())
@ -313,7 +312,7 @@ deleteAssociation uid rid conn =
liftIO $ runDelete_ conn $ Delete liftIO $ runDelete_ conn $ Delete
{ dTable = userToRoleTable { dTable = userToRoleTable
, dWhere = , dWhere =
\(auid, arid) -> auid .== C.constant uid .&& arid .== C.constant rid \(auid, arid) -> auid .== toFields uid .&& arid .== toFields rid
, dReturning = rCount , dReturning = rCount
} }
@ -323,26 +322,26 @@ updateRole
-> RoleSubmit -- The role with already updated info -> RoleSubmit -- The role with already updated info
-> PGS.Connection -> PGS.Connection
-> MateHandler Int64 -> 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 liftIO $ runUpdate_ conn $ Update
{ uTable = roleTable { uTable = roleTable
, uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _, _) -> , uUpdateWith = updateEasy (\(id_, _, _, _, _, _, _, _, _, _, _, _) ->
( id_ ( id_
, C.constant name , toFields name
, C.constant c1 , toFields c1
, C.constant c2 , toFields c2
, C.constant c3 , toFields c3
, C.constant c4 , toFields c4
, C.constant c5 , toFields c5
, C.constant c6 , toFields c6
, C.constant c7 , toFields c7
, C.constant c8 , toFields c8
, C.constant c9 , toFields c9
, C.constant c10 , toFields c10
) )
) )
, uWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _) -> , uWhere = \(id_, _, _, _, _, _, _, _, _, _, _, _) ->
id_ .== C.constant rid id_ .== toFields rid
, uReturning = rCount , uReturning = rCount
} }
@ -354,6 +353,6 @@ deleteRole rid conn =
liftIO $ runDelete_ conn $ Delete liftIO $ runDelete_ conn $ Delete
{ dTable = roleTable { dTable = roleTable
, dWhere = , dWhere =
\(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant rid \(id_, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== toFields rid
, dReturning = rCount , dReturning = rCount
} }

45
src/Model/User.hs
View file

@ -16,7 +16,6 @@ import Control.Arrow ((<<<))
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Opaleye as O import Opaleye as O
import qualified Opaleye.Constant as C
-- internal imports -- internal imports
@ -73,11 +72,11 @@ userSelect ref conn = do
orderBy (asc (\(_, ident, _, _, _, _) -> ident)) ( orderBy (asc (\(_, ident, _, _, _, _) -> ident)) (
keepWhen (\(_, _, _, ts, _, _) -> case ref of keepWhen (\(_, _, _, ts, _, _) -> case ref of
AllUsers -> AllUsers ->
C.constant True toFields True
ActiveUsers -> ActiveUsers ->
ts .>= C.constant (addDays (-30) today) ts .>= toFields (addDays (-30) today)
OldUsers -> OldUsers ->
ts .< C.constant (addDays (-30) today) ts .< toFields (addDays (-30) today)
) <<< selectTable userTable) ) <<< selectTable userTable)
) :: MateHandler [User] ) :: MateHandler [User]
mapM mapM
@ -93,8 +92,8 @@ userDetailsSelect
userDetailsSelect uid conn = do userDetailsSelect uid conn = do
users <- liftIO $ map fromDatabase <$> runSelect conn (limit 1 $ users <- liftIO $ map fromDatabase <$> runSelect conn (limit 1 $
keepWhen (\(uuid, _, _, _, _, _) -> keepWhen (\(uuid, _, _, _, _, _) ->
uuid .== C.constant uid uuid .== toFields uid
) <<< queryTable userTable ) <<< selectTable userTable
) :: MateHandler [User] ) :: MateHandler [User]
head <$> mapM head <$> mapM
(\(User i1 i2 i3 _ i5 i6) -> return $ (\(User i1 i2 i3 _ i5 i6) -> return $
@ -110,8 +109,8 @@ userBalanceSelect
userBalanceSelect conn uid = do userBalanceSelect conn uid = do
liftIO $ userBalance . fromDatabase . head <$> runSelect conn ( liftIO $ userBalance . fromDatabase . head <$> runSelect conn (
keepWhen (\(uuid, _, _, _, _, _) -> keepWhen (\(uuid, _, _, _, _, _) ->
uuid .== C.constant uid uuid .== toFields uid
) <<< queryTable userTable ) <<< selectTable userTable
) )
@ -125,12 +124,12 @@ insertUser ident email now conn = fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = userTable { iTable = userTable
, iRows = , iRows =
[ [
( C.constant (Nothing :: Maybe Int) ( toFields (Nothing :: Maybe Int)
, C.constant ident , toFields ident
, C.constant (0 :: Int) , toFields (0 :: Int)
, C.constant now , toFields now
, C.constant email , toFields email
, C.constant (Nothing :: Maybe Int) , toFields (Nothing :: Maybe Int)
) )
] ]
, iReturning = rReturning (\(uid, _, _, _, _, _) -> uid) , iReturning = rReturning (\(uid, _, _, _, _, _) -> uid)
@ -147,14 +146,14 @@ updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update
{ uTable = userTable { uTable = userTable
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _) -> , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _) ->
( id_ ( id_
, C.constant (userDetailsSubmitIdent uds) , toFields (userDetailsSubmitIdent uds)
, i3 , i3
, C.constant now , toFields now
, C.constant (userDetailsSubmitEmail uds) , toFields (userDetailsSubmitEmail uds)
, C.constant (userDetailsSubmitAvatar uds) , toFields (userDetailsSubmitAvatar uds)
) )
) )
, uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid , uWhere = \(i1, _, _, _, _, _) -> i1 .== toFields uid
, uReturning = rCount , uReturning = rCount
} }
@ -169,12 +168,12 @@ updateUserTimestamp uid now conn = liftIO $ runUpdate_ conn $ Update
( id_ ( id_
, ident , ident
, balance , balance
, C.constant now , toFields now
, email , email
, ava , ava
) )
) )
, uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid , uWhere = \(i1, _, _, _, _, _) -> i1 .== toFields uid
, uReturning = rCount , uReturning = rCount
} }
@ -188,12 +187,12 @@ addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update
, uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6) -> , uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6) ->
( id_ ( id_
, i2 , i2
, i3 + C.constant amount , i3 + toFields amount
, i4 , i4
, i5 , i5
, i6 , i6
) )
) )
, uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid , uWhere = \(i1, _, _, _, _, _) -> i1 .== toFields uid
, uReturning = rCount , uReturning = rCount
} }

2
src/Types/Purchase.hs
View file

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

8
src/Util.hs
View file

@ -82,6 +82,14 @@ sendUserNotification recipient subject message =
Nothing -> Nothing ->
return () 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 sendNotification mail = do
sendmail <- asks rsSendmailPath sendmail <- asks rsSendmailPath
liftIO $ do liftIO $ do