Merge branch 'purchase' of nek0/mateamt into master

This commit is contained in:
nek0 2019-07-21 10:22:28 +00:00 committed by Gitea
commit 57aacb1e21
7 changed files with 266 additions and 6 deletions

View File

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

View File

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

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)
@ -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 :<|>

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

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

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

45
src/Types/Purchase.hs Normal file
View File

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