make preparations for notifications

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
+  (missing, real) <-
-    mmiss <- checkProductAvailability pd conn
+    foldM
-    case mmiss of
+      (\(ms, rs) pd -> do
-      Just miss -> return
+        mmiss <- checkProductAvailability pd conn
-        ( (pd {purchaseDetailAmount = miss}):ms
+        case mmiss of
-        , pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs
+          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
+      pds
-        , pd:rs
-        )
-    )
-    ([], [])
-    pds
   mapM_ (`postBuyProductAmountUpdate` conn) real
   price <- foldM
     (\total pd ->

src/Control/Product.hs

@@ -38,12 +38,12 @@ productNew Nothing _ =
     { 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
   :: Maybe (Int, AuthMethod)

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"
     }

src/Model/Auth.hs

@@ -117,11 +117,11 @@ generateRandomText = decodeUtf8 . B64.encode <$> random 23
 
 
 selectAuthOverviews
-  :: Int
+  :: Int                        -- ^ User ID
-  -> PGS.Connection
+  -> 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

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