purchase implemented #1

Merged
nek0 merged 2 commits from purchase into master 2019-07-21 10:22:29 +00:00
4 changed files with 201 additions and 17 deletions
Showing only changes of commit a163fd40f1 - Show all commits

View file

@ -23,7 +23,7 @@ import Network.Wai
import Network.Wai.Logger import Network.Wai.Logger
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import Opaleye import Opaleye hiding (max)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
@ -171,11 +171,54 @@ products =
update Nothing _ _ = update Nothing _ _ =
throwError $ err403 throwError $ err403
buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult
buy (Just auid) pds = do buy (Just auid) pds = do
error "Buying not yet implemented"
conn <- rsConnection <$> ask 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 = auth =
authGet :<|> authGet :<|>

View file

@ -2,7 +2,9 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Model.Product where 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.Time.Calendar (Day)
import Data.Profunctor.Product (p13) import Data.Profunctor.Product (p13)
@ -11,7 +13,9 @@ import Data.Aeson.Types
import Data.Int (Int64) import Data.Int (Int64)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Error.Class (throwError)
import Control.Arrow ((<<<)) import Control.Arrow ((<<<))
@ -109,10 +113,12 @@ getProductPrice
:: PurchaseDetail :: PurchaseDetail
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -> MateHandler Int
getproductproce (PurchaseDetail bid amount) conn = do getProductPrice (PurchaseDetail bid amount) conn = do
when (amount <= 0) when (amount < 0) (
throwError $ err406 throwError $ err406
{ errBody = "Amounts less or equal zero are not acceptable" { errBody = "Amounts less or equal zero are not acceptable"
}
)
bevs <- liftIO $ runSelect conn bevs <- liftIO $ runSelect conn
( keepWhen ( keepWhen
(\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<< (\(id_, _, _, _, _, _, _, _, _, _, _, _, _) -> id_ .== C.constant bid) <<<
@ -140,6 +146,45 @@ getproductproce (PurchaseDetail bid amount) conn = do
bevs 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 insertProduct
:: ProductSubmit :: ProductSubmit
-> Insert [Int] -> Insert [Int]
@ -195,3 +240,32 @@ updateProduct sid (ProductSubmit ident price ml ava sup max apc ppc artnr) = Upd
) )
, uReturning = rCount , 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
}

View file

@ -131,6 +131,36 @@ userDetailsSelect conn id = do
) )
users 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 :: UserSubmit -> Day -> ByteString -> Insert [Int]
insertUser us now randSalt = Insert insertUser us now randSalt = Insert
{ iTable = userTable { iTable = userTable
@ -152,8 +182,8 @@ insertUser us now randSalt = Insert
} }
updateUserDetails :: Int -> UserDetailsSubmit -> Day -> Update Int64 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, _) -> , uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, i8, _) ->
( id_ ( id_
, C.constant (userDetailsSubmitIdent uds) , C.constant (userDetailsSubmitIdent uds)
@ -166,6 +196,28 @@ updateUserDetails id uds now = Update
, C.constant (fromEnum <$> userDetailsSubmitAlgo uds) , 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
} }

View file

@ -4,6 +4,8 @@ module Types.Purchase where
import Data.Text import Data.Text
import Data.Aeson
import GHC.Generics import GHC.Generics
@ -11,20 +13,33 @@ data PurchaseDetail = PurchaseDetail
{ pdBeverage :: Int { pdBeverage :: Int
, pdAmount :: Int , pdAmount :: Int
} }
deriving (Generic, Show)
instance ToJSON PurchaseDetail where instance ToJSON PurchaseDetail where
toEncoding = genericToEncoding defaultOptions 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) deriving (Generic, Show)
instance ToJSON PurchaseResult where instance ToJSON PurchaseResult where
toEncoding = genericToEncoding defaultOptions 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