From 28709dd0cf13ee80140c0e5c8e6fafe0b4501d5b Mon Sep 17 00:00:00 2001
From: nek0 <nek0@nek0.eu>
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