make preparations for notifications

This commit is contained in:
nek0 2021-06-10 17:54:57 +02:00
parent 5ee1fb4ac8
commit 28709dd0cf
5 changed files with 58 additions and 23 deletions

View file

@ -17,16 +17,22 @@ buy
-> MateHandler PurchaseResult -> MateHandler PurchaseResult
buy auth pds = do buy auth pds = do
conn <- asks rsConnection conn <- asks rsConnection
(missing, real) <- foldM (\(ms, rs) pd -> do (missing, real) <-
foldM
(\(ms, rs) pd -> do
mmiss <- checkProductAvailability pd conn mmiss <- checkProductAvailability pd conn
case mmiss of case mmiss of
Just miss -> return Just miss -> return
-- If there is less items in stock than ordered
( (pd {purchaseDetailAmount = miss}):ms ( (pd {purchaseDetailAmount = miss}):ms
-- Add number of missing items
, pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs , pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs
-- purchase remaining items in stock
) )
Nothing -> return Nothing -> return
( ms -- There are at least as many items in stock as ordered
, pd:rs ( ms -- Missing items do not change
, pd:rs -- Add everything to purchase
) )
) )
([], []) ([], [])

View file

@ -38,12 +38,12 @@ productNew Nothing _ =
{ errBody = "No Authentication present." { errBody = "No Authentication present."
} }
productOverview -- productOverview
:: Int -- :: Int
-> MateHandler ProductOverview -- -> MateHandler ProductOverview
productOverview pid = do -- productOverview pid = do
conn <- asks rsConnection -- conn <- asks rsConnection
productOverviewSelectSingle pid conn -- productOverviewSelectSingle pid conn
productStockRefill productStockRefill
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)

View file

@ -149,6 +149,21 @@ userNotify
-> PurchaseResult -> PurchaseResult
-> MateHandler () -> MateHandler ()
userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do userNotify (Just (auid, method)) boughtItems (PurchaseResult flag missing) = do
conn <- asks rsConnection
authData <- selectAuthOverviewById auid conn
user <- userDetailsSelect (authDataUser authData) conn
digestedDetails <- mapM
(\pd -> do
overview <- (productOverviewSelectSingle (purchaseDetailProduct pd) conn
return (purchaseDetailAmout pd, productOverviewIdent overview)
)
boughtItems
let messageText = mconcat $ map (<> "\n") $
[ "Hello " <> userIdent user <> ","
, ""
, "Your " <> authDataMethod authData <> " with the comment \"" <>
authDataComment authData <> "\" Just made following purchase:"<>
]
throwError $ err501 throwError $ err501
{ errBody = "userNotify: Not implemented yet" { errBody = "userNotify: Not implemented yet"
} }

View file

@ -117,11 +117,11 @@ generateRandomText = decodeUtf8 . B64.encode <$> random 23
selectAuthOverviews selectAuthOverviews
:: Int :: Int -- ^ User ID
-> PGS.Connection -> PGS.Connection -- ^ Connection Handler
-> MateHandler [AuthOverview] -> MateHandler [AuthOverview]
selectAuthOverviews uid conn = do selectAuthOverviews uid conn = do
liftIO $ map fromDatabase <$> runSelect conn (proc () -> do liftIO $ map fromDatabase <$> head <$> runSelect conn (proc () -> do
(adid, aduid, admethod, adcomment, _) <- (adid, aduid, admethod, adcomment, _) <-
queryTable authDataTable -< () queryTable authDataTable -< ()
restrict -< aduid .== C.constant uid restrict -< aduid .== C.constant uid
@ -129,6 +129,20 @@ selectAuthOverviews uid conn = do
) )
selectAuthOverviewById
:: Int -- ^ Auth Data ID
-> PGS.Connection -- ^ Connection Handler
-> MateHandler AuthOverview
selectAuthOverviews aid conn = do
liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
(adid, aduid, admethod, adcomment, _) <-
queryTable authDataTable -< ()
restrict -< adid .== C.constant aid
limit 1
returnA -< (adid, adcomment, admethod)
)
getUserAuthInfo getUserAuthInfo
:: Int :: Int
-> AuthMethod -> AuthMethod

View file

@ -91,7 +91,7 @@ userDetailsSelect
-> PGS.Connection -> PGS.Connection
-> MateHandler UserDetails -> MateHandler UserDetails
userDetailsSelect uid conn = do userDetailsSelect uid conn = do
users <- liftIO $ map fromDatabase <$> runSelect conn ( users <- liftIO $ map fromDatabase <$> runSelect conn (limit 1 $
keepWhen (\(uuid, _, _, _, _, _) -> keepWhen (\(uuid, _, _, _, _, _) ->
uuid .== C.constant uid uuid .== C.constant uid
) <<< queryTable userTable ) <<< queryTable userTable