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.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
liftIO $ runUpdate_ conn updateUserBalance auid
(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 :<|>

View file

@ -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
when (amount <= 0)
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) <<<
@ -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
}

View file

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

View file

@ -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
= PurchaseOK
| PurchaseDebtful
| PayAmount Int
data PurchaseResult = PurchaseResult
{ prFlag :: PurchaseResultFlag
, prMissingItems :: [PurchaseDetail]
}
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