get things in order
This commit is contained in:
parent
ece76fe5de
commit
a937fe4775
8 changed files with 230 additions and 119 deletions
|
|
@ -32,11 +32,11 @@ type UserAPI =
|
|||
:> Capture "id" Int :> ReqBody '[JSON] UserDetailsSubmit :> Post '[JSON] ()
|
||||
)
|
||||
:<|> "product" :>
|
||||
( "list" :> Get '[JSON] [Product]
|
||||
( "list" :> Get '[JSON] [ProductOverview]
|
||||
:<|> "new" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit
|
||||
:> Post '[JSON] Int
|
||||
:<|> "update" :> AuthProtect "header-auth"
|
||||
:> Capture "id" Int :> ReqBody '[JSON] AmountUpdate :> Post '[JSON] ()
|
||||
:> ReqBody '[JSON] AmountUpdate :> Post '[JSON] ()
|
||||
)
|
||||
:<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail]
|
||||
:> Post '[JSON] PurchaseResult
|
||||
|
|
|
|||
34
src/Main.hs
34
src/Main.hs
|
|
@ -113,7 +113,7 @@ users =
|
|||
now <- liftIO $ getCurrentTime
|
||||
randSalt <- liftIO $ random 8
|
||||
conn <- rsConnection <$> ask
|
||||
head <$> (liftIO $ runInsert_ conn (insertUser us (utctDay now) randSalt))
|
||||
insertUser us (utctDay now) randSalt conn
|
||||
|
||||
userGetUpdate :: Maybe Int -> Int -> MateHandler UserDetails
|
||||
userGetUpdate Nothing _ =
|
||||
|
|
@ -142,7 +142,7 @@ users =
|
|||
then do
|
||||
now <- liftIO $ getCurrentTime
|
||||
conn <- rsConnection <$> ask
|
||||
void $ liftIO $ runUpdate_ conn (updateUserDetails id uds (utctDay now))
|
||||
void $ updateUserDetails id uds (utctDay now) conn
|
||||
else
|
||||
throwError $ err403
|
||||
{ errBody = "Wrong Authentication present"
|
||||
|
|
@ -153,28 +153,28 @@ products =
|
|||
new :<|>
|
||||
update
|
||||
where
|
||||
list :: MateHandler [Product]
|
||||
list :: MateHandler [ProductOverview]
|
||||
list = do
|
||||
conn <- rsConnection <$> ask
|
||||
productSelect conn
|
||||
productOverviewSelect conn
|
||||
|
||||
new :: Maybe Int -> ProductSubmit -> MateHandler Int
|
||||
new (Just _) bevsub = do
|
||||
conn <- rsConnection <$> ask
|
||||
now <- liftIO $ getCurrentTime
|
||||
bevid <- head <$> (liftIO $ runInsert_ conn (insertProduct bevsub))
|
||||
void $ liftIO $ runInsert_ conn (insertNewEmptyAmount bevid now bevsub)
|
||||
bevid <- insertProduct bevsub conn
|
||||
void $ insertNewEmptyAmount bevid now bevsub conn
|
||||
return bevid
|
||||
new Nothing _ =
|
||||
throwError $ err403
|
||||
|
||||
update :: Maybe Int -> Int -> AmountUpdate -> MateHandler ()
|
||||
update (Just _) bid amosub = do
|
||||
update :: Maybe Int -> AmountUpdate -> MateHandler ()
|
||||
update (Just _) amosub@(AmountUpdate pid amount) = do
|
||||
conn <- rsConnection <$> ask
|
||||
liftIO $ do
|
||||
now <- getCurrentTime
|
||||
void $ runInsert_ conn (manualProductAmountUpdate amosub now bid)
|
||||
update Nothing _ _ =
|
||||
now <- liftIO $ getCurrentTime
|
||||
oldprice <- getLatestPriceByProductId pid conn
|
||||
void $ manualProductAmountUpdate amosub now oldprice conn
|
||||
update Nothing _ =
|
||||
throwError $ err403
|
||||
|
||||
buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult
|
||||
|
|
@ -184,8 +184,8 @@ buy (Just auid) pds = do
|
|||
mmiss <- checkProductAvailability pd conn
|
||||
case mmiss of
|
||||
Just miss -> return
|
||||
( (pd {pdAmount = miss}):ms
|
||||
, (pd {pdAmount = max 0 (pdAmount pd - miss)}:rs)
|
||||
( (pd {purchaseDetailAmount = miss}):ms
|
||||
, (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
|
||||
)
|
||||
Nothing -> return
|
||||
( ms
|
||||
|
|
@ -201,7 +201,7 @@ buy (Just auid) pds = do
|
|||
)
|
||||
0
|
||||
real
|
||||
liftIO $ runUpdate_ conn (addToUserBalance auid (-price))
|
||||
addToUserBalance auid (-price) conn
|
||||
newBalance <- userBalanceSelect conn auid
|
||||
return $ PurchaseResult
|
||||
( if newBalance < 0
|
||||
|
|
@ -215,8 +215,8 @@ buy Nothing pds = do
|
|||
mmiss <- checkProductAvailability pd conn
|
||||
case mmiss of
|
||||
Just miss -> return
|
||||
( (pd {pdAmount = miss}):ms
|
||||
, (pd {pdAmount = max 0 (pdAmount pd - miss)}:rs)
|
||||
( (pd {purchaseDetailAmount = miss}):ms
|
||||
, (pd {purchaseDetailAmount = max 0 (purchaseDetailAmount pd - miss)}:rs)
|
||||
)
|
||||
Nothing -> return
|
||||
( ms
|
||||
|
|
|
|||
|
|
@ -58,8 +58,10 @@ insertNewEmptyAmount
|
|||
:: Int -- | the associated product id
|
||||
-> UTCTime -- | current time
|
||||
-> ProductSubmit -- | submitted product data
|
||||
-> Insert [Int]
|
||||
insertNewEmptyAmount bevid now (ProductSubmit _ price _ _ _ _ _ _ _) = Insert
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int
|
||||
insertNewEmptyAmount bevid now (ProductSubmit _ price _ _ _ _ _ _ _) conn =
|
||||
fmap head $ liftIO $ runInsert_ conn $ Insert
|
||||
{ iTable = amountTable
|
||||
, iRows =
|
||||
[
|
||||
|
|
@ -142,8 +144,10 @@ manualProductAmountUpdate
|
|||
:: AmountUpdate
|
||||
-> UTCTime -- Current time
|
||||
-> Int -- Old BeveragePrice
|
||||
-> Insert [Int]
|
||||
manualProductAmountUpdate (AmountUpdate pid amount) now oldprice = Insert
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int
|
||||
manualProductAmountUpdate (AmountUpdate pid amount) now oldprice conn =
|
||||
fmap head $ liftIO $ runInsert_ conn $ Insert
|
||||
{ iTable = amountTable
|
||||
, iRows =
|
||||
[
|
||||
|
|
|
|||
|
|
@ -128,9 +128,8 @@ validateToken conn header = do
|
|||
if diffUTCTime stamp now > 0
|
||||
then return $ Just uid
|
||||
else do
|
||||
liftIO $ do
|
||||
void $ forkIO $ void $ runDelete_ conn (deleteToken header)
|
||||
threadDelay $ 1 * 10 ^ 6
|
||||
void $ deleteToken header conn
|
||||
liftIO $ threadDelay $ 1 * 10 ^ 6
|
||||
throwError $ err401
|
||||
{ errBody = "Your token expired!"
|
||||
}
|
||||
|
|
@ -169,7 +168,7 @@ generateToken (Ticket _ ident exp) (AuthHash hash) = do
|
|||
<$> (random 23)
|
||||
<*> (pure ident)
|
||||
<*> (addUTCTime (23*60) <$> getCurrentTime)
|
||||
void $ liftIO $ runInsert_ conn (insertToken token)
|
||||
void $ insertToken token conn
|
||||
return $ Granted (AuthToken $ tokenString token)
|
||||
else
|
||||
return Denied
|
||||
|
|
@ -177,8 +176,10 @@ generateToken (Ticket _ ident exp) (AuthHash hash) = do
|
|||
|
||||
insertToken
|
||||
:: Token
|
||||
-> Insert [ByteString]
|
||||
insertToken (Token tString tUser tExpiry) = Insert
|
||||
-> PGS.Connection
|
||||
-> MateHandler ByteString
|
||||
insertToken (Token tString tUser tExpiry) conn =
|
||||
fmap head $ liftIO $ runInsert_ conn $ Insert
|
||||
{ iTable = tokenTable
|
||||
, iRows =
|
||||
[
|
||||
|
|
@ -194,8 +195,10 @@ insertToken (Token tString tUser tExpiry) = Insert
|
|||
|
||||
deleteToken
|
||||
:: ByteString
|
||||
-> Opaleye.Delete Int64
|
||||
deleteToken tstr = Delete
|
||||
-> PGS.Connection
|
||||
-> Handler Int64
|
||||
deleteToken tstr conn =
|
||||
liftIO $ runDelete_ conn $ Delete
|
||||
{ dTable = tokenTable
|
||||
, dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr)
|
||||
, dReturning = rCount
|
||||
|
|
@ -204,8 +207,9 @@ deleteToken tstr = Delete
|
|||
|
||||
deleteTokenByUserId
|
||||
:: Int
|
||||
-> Opaleye.Delete Int64
|
||||
deleteTokenByUserId uid = Delete
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int64
|
||||
deleteTokenByUserId uid conn = liftIO $ runDelete_ conn $ Delete
|
||||
{ dTable = tokenTable
|
||||
, dWhere = (\(_, rid, _) -> rid .== C.constant uid)
|
||||
, dReturning = rCount
|
||||
|
|
@ -262,4 +266,4 @@ processLogout
|
|||
-> MateHandler ()
|
||||
processLogout uid = do
|
||||
conn <- rsConnection <$> ask
|
||||
liftIO $ void $ runDelete_ conn (deleteTokenByUserId uid)
|
||||
void $ deleteTokenByUserId uid conn
|
||||
|
|
|
|||
|
|
@ -1,12 +1,15 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE Arrows #-}
|
||||
module Model.Product where
|
||||
|
||||
import Servant.Server
|
||||
|
||||
import Data.Text as T hiding (head, foldl)
|
||||
import Data.Time.Calendar (Day)
|
||||
import Data.Profunctor.Product (p10)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Profunctor.Product (p9)
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
|
|
@ -17,7 +20,7 @@ import Control.Monad (when)
|
|||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Error.Class (throwError)
|
||||
|
||||
import Control.Arrow ((<<<))
|
||||
import Control.Arrow ((<<<), returnA)
|
||||
|
||||
import qualified Database.PostgreSQL.Simple as PGS
|
||||
|
||||
|
|
@ -29,6 +32,7 @@ import Opaleye.Constant as C
|
|||
-- internal imports
|
||||
|
||||
import Types
|
||||
import Model.Amount
|
||||
|
||||
initProduct :: PGS.Query
|
||||
initProduct = mconcat
|
||||
|
|
@ -42,7 +46,7 @@ initProduct = mconcat
|
|||
, "product_avatar integer,"
|
||||
, "product_supplier integer,"
|
||||
, "product_max_amount integer not null,"
|
||||
, "product_total_bought integer not null,"
|
||||
-- , "product_total_bought integer not null,"
|
||||
, "product_amount_per_crate integer not null,"
|
||||
, "product_price_per_crate integer,"
|
||||
, "product_art_nr varchar(128)"
|
||||
|
|
@ -59,7 +63,7 @@ productTable :: Table
|
|||
, FieldNullable SqlInt4
|
||||
, FieldNullable SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlInt4
|
||||
-- , Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, FieldNullable SqlInt4
|
||||
, FieldNullable SqlText
|
||||
|
|
@ -73,13 +77,13 @@ productTable :: Table
|
|||
, FieldNullable SqlInt4
|
||||
, FieldNullable SqlInt4
|
||||
, Field SqlInt4
|
||||
, Field SqlInt4
|
||||
-- , Field SqlInt4
|
||||
, Field SqlInt4
|
||||
, FieldNullable SqlInt4
|
||||
, FieldNullable SqlText
|
||||
)
|
||||
productTable = table "product" (
|
||||
p10
|
||||
p9
|
||||
( tableField "product_id"
|
||||
, tableField "product_ident"
|
||||
-- , tableField "product_price"
|
||||
|
|
@ -89,13 +93,14 @@ productTable = table "product" (
|
|||
, tableField "product_avatar"
|
||||
, tableField "product_supplier"
|
||||
, tableField "product_max_amount"
|
||||
, tableField "product_total_bought"
|
||||
-- , tableField "product_total_bought"
|
||||
, tableField "product_amount_per_crate"
|
||||
, tableField "product_price_per_crate"
|
||||
, tableField "product_art_nr"
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
productSelect
|
||||
:: PGS.Connection
|
||||
-> MateHandler [Product]
|
||||
|
|
@ -112,15 +117,78 @@ productSelect conn = do
|
|||
, Maybe Int
|
||||
, Maybe Int
|
||||
, Int
|
||||
, Int
|
||||
-- , Int
|
||||
, Int
|
||||
, Maybe Int
|
||||
, Maybe T.Text
|
||||
)
|
||||
]
|
||||
mapM
|
||||
(\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, i10, i11, i12, i13) -> return $
|
||||
Product i1 i2 {-i3 i4 i5-} i6 i7 i8 i9 i10 i11 i12 i13
|
||||
(\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, {-i10,-} i11, i12, i13) -> return $
|
||||
Product i1 i2 {-i3 i4 i5-} i6 i7 i8 i9 {-i10-} i11 i12 i13
|
||||
)
|
||||
bevs
|
||||
|
||||
|
||||
productOverviewSelect
|
||||
:: PGS.Connection
|
||||
-> MateHandler [ProductOverview]
|
||||
productOverviewSelect conn = do
|
||||
bevs <- liftIO $ runSelect conn
|
||||
( proc () -> do
|
||||
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
|
||||
returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13)
|
||||
) :: MateHandler
|
||||
[ ( Int
|
||||
, T.Text
|
||||
-- , Int
|
||||
-- , Int
|
||||
-- , Int
|
||||
, Int
|
||||
, Maybe Int
|
||||
, Maybe Int
|
||||
, Int
|
||||
-- , Int
|
||||
, Int
|
||||
, Maybe Int
|
||||
, Maybe T.Text
|
||||
)
|
||||
]
|
||||
mapM
|
||||
(\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, {-i10,-} i11, i12, i13) -> do
|
||||
amounts <- liftIO $ runSelect conn
|
||||
( proc () -> do
|
||||
stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
|
||||
(queryTable amountTable) -< ()
|
||||
restrict -< C.constant i1 .== a1
|
||||
returnA -< stuff
|
||||
) :: MateHandler
|
||||
[ ( Int
|
||||
, UTCTime
|
||||
, Int
|
||||
, Int
|
||||
, Bool
|
||||
)
|
||||
]
|
||||
(i3, i4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
|
||||
i5 <- return $ (\(_, x) -> x) $
|
||||
foldl
|
||||
(\(bef, van) (_, _, amo, _, ver) ->
|
||||
if ver
|
||||
then (amo, if amo < bef then van + (bef - amo) else van)
|
||||
else (amo, van)
|
||||
)
|
||||
(0, 0)
|
||||
(Prelude.reverse amounts)
|
||||
i10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
|
||||
if ver
|
||||
then (amo, tot)
|
||||
else (amo, tot + (bef - amo))
|
||||
)
|
||||
(0, 0)
|
||||
(Prelude.reverse amounts)
|
||||
return $ ProductOverview
|
||||
i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13
|
||||
)
|
||||
bevs
|
||||
|
||||
|
|
@ -203,8 +271,10 @@ productSelect conn = do
|
|||
|
||||
insertProduct
|
||||
:: ProductSubmit
|
||||
-> Insert [Int]
|
||||
insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) = Insert
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int
|
||||
insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) conn =
|
||||
fmap head $ liftIO $ runInsert_ conn $ Insert
|
||||
{ iTable = productTable
|
||||
, iRows =
|
||||
[
|
||||
|
|
@ -217,13 +287,13 @@ insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) = Insert
|
|||
, C.constant ava
|
||||
, C.constant sup
|
||||
, C.constant max
|
||||
, C.constant (0 :: Int)
|
||||
-- , C.constant (0 :: Int)
|
||||
, C.constant apc
|
||||
, C.constant ppc
|
||||
, C.constant artnr
|
||||
)
|
||||
]
|
||||
, iReturning = rReturning (\(id, _, _, _, _, _, _, _, _, _) -> id)
|
||||
, iReturning = rReturning (\(id, _, _, _, _, _, _, _, _) -> id)
|
||||
, iOnConflict = Nothing
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -173,8 +173,13 @@ userBalanceSelect conn id = do
|
|||
users
|
||||
|
||||
|
||||
insertUser :: UserSubmit -> Day -> ByteString -> Insert [Int]
|
||||
insertUser us now randSalt = Insert
|
||||
insertUser
|
||||
:: UserSubmit
|
||||
-> Day
|
||||
-> ByteString
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int
|
||||
insertUser us now randSalt conn = fmap head $ liftIO $ runInsert_ conn $ Insert
|
||||
{ iTable = userTable
|
||||
, iRows =
|
||||
[
|
||||
|
|
@ -193,8 +198,13 @@ insertUser us now randSalt = Insert
|
|||
, iOnConflict = Nothing
|
||||
}
|
||||
|
||||
updateUserDetails :: Int -> UserDetailsSubmit -> Day -> Update Int64
|
||||
updateUserDetails uid uds now = Update
|
||||
updateUserDetails
|
||||
:: Int
|
||||
-> UserDetailsSubmit
|
||||
-> Day
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int64
|
||||
updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update
|
||||
{ uTable = userTable
|
||||
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, i8, _) ->
|
||||
( id_
|
||||
|
|
@ -215,8 +225,9 @@ updateUserDetails uid uds now = Update
|
|||
addToUserBalance
|
||||
:: Int
|
||||
-> Int
|
||||
-> Update Int64
|
||||
addToUserBalance uid amount = Update
|
||||
-> PGS.Connection
|
||||
-> MateHandler Int64
|
||||
addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update
|
||||
{ uTable = userTable
|
||||
, uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6, i7, i8, i9) ->
|
||||
( id_
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ data Product = Product
|
|||
, productAvatar :: Maybe Int
|
||||
, productSupplier :: Maybe Int
|
||||
, productMaxAmount :: Int
|
||||
, productTotalBought :: Int
|
||||
-- , productTotalBought :: Int
|
||||
, productAmountPerCrate :: Int
|
||||
, productPricePerCrate :: Maybe Int
|
||||
, productArtNr :: Maybe T.Text
|
||||
|
|
@ -29,6 +29,28 @@ instance ToJSON Product where
|
|||
instance FromJSON Product
|
||||
|
||||
|
||||
data ProductOverview = ProductOverview
|
||||
{ productOverviewId :: Int
|
||||
, productOverviewIdent :: T.Text
|
||||
, productOverviewPrice :: Int
|
||||
, productOverviewAmount :: Int
|
||||
, productOverviewVanish :: Int
|
||||
, productOverviewMl :: Int
|
||||
, productOverviewAvatar :: Maybe Int
|
||||
, productOverviewSupplier :: Maybe Int
|
||||
, productOverviewMaxAmount :: Int
|
||||
, productOverviewTotalBought :: Int
|
||||
, productOverviewAmountPerCrate :: Int
|
||||
, productOverviewPricePerCrate :: Maybe Int
|
||||
, productOverviewArtNr :: Maybe T.Text
|
||||
} deriving (Generic, Show)
|
||||
|
||||
instance ToJSON ProductOverview where
|
||||
toEncoding = genericToEncoding defaultOptions
|
||||
|
||||
instance FromJSON ProductOverview
|
||||
|
||||
|
||||
data ProductSubmit = ProductSubmit
|
||||
{ productSubmitIdent :: T.Text
|
||||
, productSubmitPrice :: Int
|
||||
|
|
|
|||
|
|
@ -10,8 +10,8 @@ import GHC.Generics
|
|||
|
||||
|
||||
data PurchaseDetail = PurchaseDetail
|
||||
{ pdBeverage :: Int
|
||||
, pdAmount :: Int
|
||||
{ purchaseDetailBeverage :: Int
|
||||
, purchaseDetailAmount :: Int
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
|
|
@ -22,8 +22,8 @@ instance FromJSON PurchaseDetail
|
|||
|
||||
|
||||
data PurchaseResult = PurchaseResult
|
||||
{ prFlag :: PurchaseResultFlag
|
||||
, prMissingItems :: [PurchaseDetail]
|
||||
{ purchaseResultFlag :: PurchaseResultFlag
|
||||
, purchaseResultMissingItems :: [PurchaseDetail]
|
||||
}
|
||||
deriving (Generic, Show)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue