diff --git a/mateamt.cabal b/mateamt.cabal index 8313bcb..8e96a50 100644 --- a/mateamt.cabal +++ b/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 diff --git a/src/API.hs b/src/API.hs index ddb6ac9..ff0210d 100644 --- a/src/API.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 84d984c..d83edaf 100644 --- a/src/Main.hs +++ b/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 :<|> diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 8893435..604c9e5 100644 --- a/src/Model/Product.hs +++ b/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 + } diff --git a/src/Model/User.hs b/src/Model/User.hs index c4f13b1..2848994 100644 --- a/src/Model/User.hs +++ b/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 } diff --git a/src/Types.hs b/src/Types.hs index d9f12ed..f302c75 100644 --- a/src/Types.hs +++ b/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 diff --git a/src/Types/Purchase.hs b/src/Types/Purchase.hs new file mode 100644 index 0000000..c1e6714 --- /dev/null +++ b/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