mateamt.cabal

@@ -33,6 +33,7 @@ executable mateamt
                      , Types.Reader
                      , Types.Refine
                      , Types.User
+                     , Types.Purchase
   -- other-extensions:
   build-depends:       base ^>=4.12.0.0
                      , servant

src/API.hs

@@ -38,6 +38,8 @@ type UserAPI =
     :<|> "update" :> AuthProtect "header-auth"
       :> Capture "id" Int :> ReqBody '[JSON] ProductSubmit :> Post '[JSON] ()
     )
+  :<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail]
+    :> Post '[JSON] PurchaseResult
   :<|> "auth" :> 
     ( "get" :> ReqBody '[JSON] Int :> Post '[JSON] AuthInfo
     :<|> "send" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult

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)
 
@@ -66,6 +66,7 @@ app initState =
       (`runReaderT` initState)
       ( users :<|>
         products :<|>
+        buy :<|>
         auth
       )
 
@@ -170,6 +171,55 @@ products =
     update Nothing _ _ =
       throwError $ err403
 
+buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult
+buy (Just auid) 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
+  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 :<|>
   authSend :<|>

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 ((<<<))
 
@@ -105,6 +109,82 @@ productSelect conn = do
     bevs
 
 
+getProductPrice
+  :: PurchaseDetail
+  -> PGS.Connection
+  -> MateHandler Int
+getProductPrice (PurchaseDetail bid amount) conn = 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
+          )
+        ]
+  (amount *) <$> head <$> mapM
+    (\(i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13) -> return $
+      i3
+      )
+    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]
@@ -160,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
-  { uTable = userTable
+updateUserDetails uid uds now = Update
+  { 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)
-  , uReturning = rCount
+  , uWhere      = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant uid)
+  , 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.hs

@@ -7,3 +7,4 @@ import Types.Product as T
 import Types.Refine as T
 import Types.Reader as T
 import Types.User as T
+import Types.Purchase as T

src/Types/Purchase.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Types.Purchase where
+
+import Data.Text
+
+import Data.Aeson
+
+import GHC.Generics
+
+
+data PurchaseDetail = PurchaseDetail
+  { pdBeverage :: Int
+  , pdAmount   :: Int
+  }
+  deriving (Generic, Show)
+
+instance ToJSON PurchaseDetail where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON PurchaseDetail
+
+
+data PurchaseResult = PurchaseResult
+  { prFlag         :: PurchaseResultFlag
+  , prMissingItems :: [PurchaseDetail]
+  }
+  deriving (Generic, Show)
+
+instance ToJSON PurchaseResult where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON PurchaseResult
+
+
+data PurchaseResultFlag
+  = PurchaseOK
+  | PurchaseDebtful
+  | PayAmount Int
+  deriving (Generic, Show)
+
+instance ToJSON PurchaseResultFlag where
+  toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON PurchaseResultFlag