finish implementing purchase

src/Main.hs

@@ -23,7 +23,7 @@ import Network.Wai
 import Network.Wai.Logger
 import Network.Wai.Handler.Warp
 
-import Opaleye
+import Opaleye hiding (max)
 
 import Control.Monad.IO.Class (liftIO)
 
@@ -171,11 +171,54 @@ products =
     update Nothing _ _ =
       throwError $ err403
 
+buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult
 buy (Just auid) pds = do
-  error "Buying not yet implemented"
   conn <- rsConnection <$> ask
-  price <- foldl (\total pd -> total + getBeveragePrice pd) 0 pds
+  (missing, real) <- foldM (\acc@(ms, rs) pd -> do
-  liftIO $ runUpdate_ conn updateUserBalance auid
+    mmiss <- checkProductAvailability conn pd
+    case mmiss of
+      Just miss -> return
+        ( (pd {pdAmount = miss}):ms
+        , (pd {pdAmount = max 0 (pdAmount pd - miss)}:rs)
+        )
+      Nothing -> return
+        ( ms
+        , pd:rs
+        )
+    )
+    ([], [])
+    pds
+  void$ liftIO $ mapM_ (\pd -> runUpdate_ conn (reduceProductAmount pd)) real
+  price <- foldM (\total pd -> fmap (+ total) (getProductPrice pd conn)) 0 real
+  liftIO $ runUpdate_ conn (addToUserBalance auid (-price))
+  newBalance <- userBalanceSelect conn auid
+  return $ PurchaseResult
+    ( if newBalance < 0
+      then PurchaseDebtful
+      else PurchaseOK
+    )
+    missing
+buy Nothing pds = do
+  conn <- rsConnection <$> ask
+  (missing, real) <- foldM (\acc@(ms, rs) pd -> do
+    mmiss <- checkProductAvailability conn pd
+    case mmiss of
+      Just miss -> return
+        ( (pd {pdAmount = miss}):ms
+        , (pd {pdAmount = max 0 (pdAmount pd - miss)}:rs)
+        )
+      Nothing -> return
+        ( ms
+        , pd:rs
+        )
+    )
+    ([], [])
+    pds
+  void $ liftIO $ mapM_ (\pd -> runUpdate_ conn (reduceProductAmount pd)) real
+  price <- foldM (\total pd -> fmap (+ total) (getProductPrice pd conn)) 0 real
+  return $ PurchaseResult
+    (PayAmount price)
+    missing
 
 auth =
   authGet :<|>

src/Model/Product.hs

@@ -2,7 +2,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Model.Product where
 
-import Data.Text as T
+import Servant.Server
+
+import Data.Text as T hiding (head)
 import Data.Time.Calendar (Day)
 import Data.Profunctor.Product (p13)
 
@@ -11,7 +13,9 @@ import Data.Aeson.Types
 
 import Data.Int (Int64)
 
+import Control.Monad (when)
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Error.Class (throwError)
 
 import Control.Arrow ((<<<))
 
@@ -109,10 +113,12 @@ getProductPrice
   :: PurchaseDetail
   -> PGS.Connection
   -> MateHandler Int
-getproductproce (PurchaseDetail bid amount) conn = do
+getProductPrice (PurchaseDetail bid amount) conn = do
-  when (amount <= 0)
+  when (amount < 0) (
     throwError $ err406
       { errBody = "Amounts less or equal zero are not acceptable"
+      }
+    )
   bevs <- liftIO $ runSelect conn
     ( keepWhen
       (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<<
@@ -140,6 +146,45 @@ getproductproce (PurchaseDetail bid amount) conn = do
     bevs
 
 
+checkProductAvailability
+  :: PGS.Connection
+  -> PurchaseDetail
+  -> MateHandler (Maybe Int) -- | returns maybe missing amount
+checkProductAvailability conn (PurchaseDetail bid amount) = do
+  when (amount <= 0) $
+    throwError $ err406
+      { errBody = "Amounts less or equal zero are not acceptable"
+      }
+  bevs <- liftIO $ runSelect conn
+    ( keepWhen
+      (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<<
+        queryTable productTable
+    ) :: MateHandler
+        [ ( Int
+          , T.Text
+          , Int
+          , Int
+          , Int
+          , Int
+          , Maybe Int
+          , Maybe Int
+          , Int
+          , Int
+          , Int
+          , Maybe Int
+          , Maybe T.Text
+          )
+        ]
+  realamount <- head <$> mapM
+    (\(i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13) -> return $
+      i4
+      )
+    bevs
+  if realamount < amount
+  then return (Just (amount - realamount))
+  else return Nothing
+
+
 insertProduct
   :: ProductSubmit
   -> Insert [Int]
@@ -195,3 +240,32 @@ updateProduct sid (ProductSubmit ident price ml ava sup max apc ppc artnr) = Upd
     )
   , uReturning = rCount
   }
+
+reduceProductAmount
+  :: PurchaseDetail
+  -> Update Int64
+reduceProductAmount (PurchaseDetail pid amount) = Update
+  { uTable      = productTable
+  , uUpdateWith = updateEasy
+    (\(id_, ident, price, amo, van, ml, ava, sup, max, tot, apc, ppc, artnr) ->
+      ( id_
+      , ident
+      , price
+      , amo - C.constant amount
+      , van
+      , ml
+      , ava
+      , sup
+      , max
+      , tot + C.constant amount
+      , apc
+      , ppc
+      , artnr
+      )
+    )
+  , uWhere      = 
+    (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) ->
+      id_ .== C.constant pid
+    )
+  , uReturning = rCount
+  }

src/Model/User.hs

@@ -131,6 +131,36 @@ userDetailsSelect conn id = do
       )
     users
 
+
+userBalanceSelect
+  :: PGS.Connection
+  -> Int
+  -> MateHandler Int
+userBalanceSelect conn id = do
+  today <- utctDay <$> (liftIO $ getCurrentTime)
+  users <- liftIO $ runSelect conn (
+      keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
+        uid .== C.constant id
+        ) <<< queryTable userTable
+      ) :: MateHandler
+          [ ( Int
+            , Text
+            , Int
+            , Day
+            , Maybe Text
+            , Maybe Int
+            , ByteString
+            , Maybe ByteString
+            , Maybe Int
+            )
+          ]
+  head <$> mapM
+    (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
+      i3
+      )
+    users
+
+
 insertUser :: UserSubmit -> Day -> ByteString -> Insert [Int]
 insertUser us now randSalt = Insert
   { iTable = userTable
@@ -152,8 +182,8 @@ insertUser us now randSalt = Insert
   }
 
 updateUserDetails :: Int -> UserDetailsSubmit -> Day -> Update Int64
-updateUserDetails id uds now = Update
+updateUserDetails uid uds now = Update
-  { uTable = userTable
+  { uTable      = userTable
   , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, i8, _) ->
       ( id_
       , C.constant (userDetailsSubmitIdent uds)
@@ -166,6 +196,28 @@ updateUserDetails id uds now = Update
       , C.constant (fromEnum <$> userDetailsSubmitAlgo uds)
       )
     )
-  , uWhere = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant id)
+  , uWhere      = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant uid)
-  , uReturning = rCount
+  , uReturning  = rCount
+  }
+
+addToUserBalance
+  :: Int
+  -> Int
+  -> Update Int64
+addToUserBalance uid amount = Update
+  { uTable      = userTable
+  , uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6, i7, i8, i9) ->
+      ( id_
+      , i2
+      , i3 + C.constant amount
+      , i4
+      , i5
+      , i6
+      , i7
+      , i8
+      , i9
+      )
+    )
+  , uWhere      = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant uid)
+  , uReturning  = rCount
   }

src/Types/Purchase.hs

@@ -4,6 +4,8 @@ module Types.Purchase where
 
 import Data.Text
 
+import Data.Aeson
+
 import GHC.Generics
 
 
@@ -11,20 +13,33 @@ data PurchaseDetail = PurchaseDetail
   { pdBeverage :: Int
   , pdAmount   :: Int
   }
+  deriving (Generic, Show)
 
 instance ToJSON PurchaseDetail where
   toEncoding = genericToEncoding defaultOptions
 
-instance fromJSON PurchaseDetail
+instance FromJSON PurchaseDetail
 
 
-data PurchaseResult
+data PurchaseResult = PurchaseResult
-  = PurchaseOK
+  { prFlag         :: PurchaseResultFlag
-  | PurchaseDebtful
+  , prMissingItems :: [PurchaseDetail]
-  | PayAmount Int
+  }
   deriving (Generic, Show)
 
 instance ToJSON PurchaseResult where
   toEncoding = genericToEncoding defaultOptions
 
-instance fromJSON PurchaseResult
+instance FromJSON PurchaseResult
+
+
+data PurchaseResultFlag
+  = PurchaseOK
+  | PurchaseDebtful
+  | PayAmount Int
+  deriving (Generic, Show)
+
+instance ToJSON PurchaseResultFlag where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON PurchaseResultFlag