nek0/mateamt
1
0
Fork 0
Code Issues Pull requests Releases Activity

get things in order

Browse source
This commit is contained in:
nek0 2019-07-28 11:55:22 +02:00
parent ece76fe5de
commit a937fe4775
8 changed files with 230 additions and 119 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
src/API.hs
View file

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

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

64
src/Model/Amount.hs
View file

@ -58,21 +58,23 @@ insertNewEmptyAmount
:: Int -- | the associated product id
-> UTCTime -- | current time
-> ProductSubmit -- | submitted product data
-> Insert [Int]
insertNewEmptyAmount bevid now (ProductSubmit _ price _ _ _ _ _ _ _) = Insert
{ iTable = amountTable
, iRows =
[
( C.constant bevid
, C.constant now
, C.constant (0 :: Int)
, C.constant price
, C.constant False
)
]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
-> PGS.Connection
-> MateHandler Int
insertNewEmptyAmount bevid now (ProductSubmit _ price _ _ _ _ _ _ _) conn =
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = amountTable
, iRows =
[
( C.constant bevid
, C.constant now
, C.constant (0 :: Int)
, C.constant price
, C.constant False
)
]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
getLatestPriceByProductId
:: Int -- The associated Product ID
@ -142,21 +144,23 @@ manualProductAmountUpdate
:: AmountUpdate
-> UTCTime -- Current time
-> Int -- Old BeveragePrice
-> Insert [Int]
manualProductAmountUpdate (AmountUpdate pid amount) now oldprice = Insert
{ iTable = amountTable
, iRows =
[
( C.constant pid
, C.constant now
, C.constant amount
, C.constant oldprice
, C.constant True
)
]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
-> PGS.Connection
-> MateHandler Int
manualProductAmountUpdate (AmountUpdate pid amount) now oldprice conn =
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = amountTable
, iRows =
[
( C.constant pid
, C.constant now
, C.constant amount
, C.constant oldprice
, C.constant True
)
]
, iReturning = rReturning (\(id_, _, _, _, _) -> id_)
, iOnConflict = Nothing
}
postBuyProductAmountUpdate
:: PurchaseDetail

56
src/Model/Auth.hs
View file

@ -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,35 +176,40 @@ generateToken (Ticket _ ident exp) (AuthHash hash) = do
insertToken
:: Token
-> Insert [ByteString]
insertToken (Token tString tUser tExpiry) = Insert
{ iTable = tokenTable
, iRows =
[
( C.constant tString
, C.constant tUser
, C.constant tExpiry
)
]
, iReturning = rReturning (\(ident, _, _) -> ident)
, iOnConflict = Nothing
}
-> PGS.Connection
-> MateHandler ByteString
insertToken (Token tString tUser tExpiry) conn =
fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = tokenTable
, iRows =
[
( C.constant tString
, C.constant tUser
, C.constant tExpiry
)
]
, iReturning = rReturning (\(ident, _, _) -> ident)
, iOnConflict = Nothing
}
deleteToken
:: ByteString
-> Opaleye.Delete Int64
deleteToken tstr = Delete
{ dTable = tokenTable
, dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr)
, dReturning = rCount
}
-> PGS.Connection
-> Handler Int64
deleteToken tstr conn =
liftIO $ runDelete_ conn $ Delete
{ dTable = tokenTable
, dWhere = (\(rtstr, _, _) -> rtstr .== C.constant tstr)
, dReturning = rCount
}
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

136
src/Model/Product.hs
View file

@ -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,29 +271,31 @@ productSelect conn = do
insertProduct
:: ProductSubmit
-> Insert [Int]
insertProduct (ProductSubmit ident price ml ava sup max apc ppc artnr) = Insert
{ iTable = productTable
, iRows =
[
( C.constant (Nothing :: Maybe Int)
, C.constant ident
-- , C.constant price
-- , C.constant (0 :: Int)
-- , C.constant (0 :: Int)
, C.constant ml
, C.constant ava
, C.constant sup
, C.constant max
, C.constant (0 :: Int)
, C.constant apc
, C.constant ppc
, C.constant artnr
)
]
, iReturning = rReturning (\(id, _, _, _, _, _, _, _, _, _) -> id)
, iOnConflict = Nothing
}
-> 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 =
[
( C.constant (Nothing :: Maybe Int)
, C.constant ident
-- , C.constant price
-- , C.constant (0 :: Int)
-- , C.constant (0 :: Int)
, C.constant ml
, C.constant ava
, C.constant sup
, C.constant max
-- , C.constant (0 :: Int)
, C.constant apc
, C.constant ppc
, C.constant artnr
)
]
, iReturning = rReturning (\(id, _, _, _, _, _, _, _, _) -> id)
, iOnConflict = Nothing
}
-- updateProduct

23
src/Model/User.hs
View file

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

24
src/Types/Product.hs
View file

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

8
src/Types/Purchase.hs
View file

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