From 28709dd0cf13ee80140c0e5c8e6fafe0b4501d5b Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 10 Jun 2021 17:54:57 +0200 Subject: [PATCH] make preparations for notifications --- src/Control/Buy.hs | 32 +++++++++++++++++++------------- src/Control/Product.hs | 12 ++++++------ src/Control/User.hs | 15 +++++++++++++++ src/Model/Auth.hs | 20 +++++++++++++++++--- src/Model/User.hs | 2 +- 5 files changed, 58 insertions(+), 23 deletions(-) diff --git a/src/Control/Buy.hs b/src/Control/Buy.hs index c833cdb..875d948 100644 --- a/src/Control/Buy.hs +++ b/src/Control/Buy.hs @@ -17,20 +17,26 @@ buy -> MateHandler PurchaseResult buy auth pds = do conn <- asks rsConnection - (missing, real) <- foldM (\(ms, rs) pd -> do - mmiss <- checkProductAvailability pd conn - case mmiss of - Just miss -> return - ( (pd {purchaseDetailAmount = miss}):ms - , pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs + (missing, real) <- + foldM + (\(ms, rs) pd -> do + mmiss <- checkProductAvailability pd conn + case mmiss of + Just miss -> return + -- If there is less items in stock than ordered + ( (pd {purchaseDetailAmount = miss}):ms + -- Add number of missing items + , pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs + -- purchase remaining items in stock + ) + Nothing -> return + -- There are at least as many items in stock as ordered + ( ms -- Missing items do not change + , pd:rs -- Add everything to purchase + ) ) - Nothing -> return - ( ms - , pd:rs - ) - ) - ([], []) - pds + ([], []) + pds mapM_ (`postBuyProductAmountUpdate` conn) real price <- foldM (\total pd -> diff --git a/src/Control/Product.hs b/src/Control/Product.hs index 74b665f..fc9954e 100644 --- a/src/Control/Product.hs +++ b/src/Control/Product.hs @@ -38,12 +38,12 @@ productNew Nothing _ = { errBody = "No Authentication present." } -productOverview - :: Int - -> MateHandler ProductOverview -productOverview pid = do - conn <- asks rsConnection - productOverviewSelectSingle pid conn +-- productOverview +-- :: Int +-- -> MateHandler ProductOverview +-- productOverview pid = do +-- conn <- asks rsConnection +-- productOverviewSelectSingle pid conn productStockRefill :: Maybe (Int, AuthMethod) diff --git a/src/Control/User.hs b/src/Control/User.hs index cab5c77..daafc4b 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -149,6 +149,21 @@ userNotify -> PurchaseResult -> MateHandler () 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 { errBody = "userNotify: Not implemented yet" } diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index 9ce843f..21772a8 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -117,11 +117,11 @@ generateRandomText = decodeUtf8 . B64.encode <$> random 23 selectAuthOverviews - :: Int - -> PGS.Connection + :: Int -- ^ User ID + -> PGS.Connection -- ^ Connection Handler -> MateHandler [AuthOverview] selectAuthOverviews uid conn = do - liftIO $ map fromDatabase <$> runSelect conn (proc () -> do + liftIO $ map fromDatabase <$> head <$> runSelect conn (proc () -> do (adid, aduid, admethod, adcomment, _) <- queryTable authDataTable -< () 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 :: Int -> AuthMethod diff --git a/src/Model/User.hs b/src/Model/User.hs index d22d538..d434e46 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -91,7 +91,7 @@ userDetailsSelect -> PGS.Connection -> MateHandler UserDetails userDetailsSelect uid conn = do - users <- liftIO $ map fromDatabase <$> runSelect conn ( + users <- liftIO $ map fromDatabase <$> runSelect conn (limit 1 $ keepWhen (\(uuid, _, _, _, _, _) -> uuid .== C.constant uid ) <<< queryTable userTable