make more instances of ToDatabase and FromDatabase

This commit is contained in:
nek0 2020-08-26 21:29:39 +02:00
parent bc4fa1c6ee
commit 3d2971baa3
7 changed files with 166 additions and 130 deletions

View File

@ -18,6 +18,7 @@ import Opaleye.Constant as C
-- internal imports -- internal imports
import Types import Types
import Classes
initAmount :: PGS.Query initAmount :: PGS.Query
initAmount = mconcat initAmount = mconcat
@ -82,40 +83,21 @@ getLatestPriceByProductId
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -- The price in cents -> MateHandler Int -- The price in cents
getLatestPriceByProductId pid conn = do getLatestPriceByProductId pid conn = do
amounts <- liftIO $ runSelect conn $ liftIO $ amountPrice . fromDatabase . head <$> runSelect conn (
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts))
(keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< queryTable amountTable) (keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid)
:: MateHandler <<< queryTable amountTable)
[ ( Int )
, UTCTime
, Int
, Int
, Bool
)
]
head <$> mapM
(\(_, _, _, price, _) -> return price)
amounts
getLatestAmountByProductId getLatestAmountByProductId
:: Int -- The associated Product ID :: Int -- The associated Product ID
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -- The amount -> MateHandler Int -- The amount
getLatestAmountByProductId pid conn = do getLatestAmountByProductId pid conn = do
amounts <- liftIO $ runSelect conn $ liftIO $ amountAmount . fromDatabase . head <$> runSelect conn (
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts))
(keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< queryTable amountTable) (keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid)
:: MateHandler <<< queryTable amountTable)
[ ( Int
, UTCTime
, Int
, Int
, Bool
)
]
return (head $ map
(\(_, _, amount, _, _) -> amount)
amounts
) )
getLatestTotalPrice getLatestTotalPrice
@ -123,41 +105,23 @@ getLatestTotalPrice
-> PGS.Connection -> PGS.Connection
-> MateHandler Int -- The price in cents -> MateHandler Int -- The price in cents
getLatestTotalPrice (PurchaseDetail pid amount) conn = do getLatestTotalPrice (PurchaseDetail pid amount) conn = do
amounts <- liftIO $ runSelect conn $ liftIO $ (amount *) . amountPrice . fromDatabase . head <$>
limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $ runSelect conn (
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< limit 1 $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $
queryTable amountTable keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<
:: MateHandler queryTable amountTable
[ ( Int )
, UTCTime
, Int
, Int
, Bool
)
]
return $ ((amount *) . head) (map
(\(_, _, _, price, _) -> price)
amounts
)
checkProductAvailability checkProductAvailability
:: PurchaseDetail :: PurchaseDetail
-> PGS.Connection -> PGS.Connection
-> MateHandler (Maybe Int) -- ^ Returns maybe missing amount -> MateHandler (Maybe Int) -- ^ Returns maybe missing amount
checkProductAvailability (PurchaseDetail pid amount) conn = do checkProductAvailability (PurchaseDetail pid amount) conn = do
realamount <- (\(_, _, ramount, _, _) -> ramount) . head <$> realamount <- amountAmount . fromDatabase . head <$>
(liftIO $ runSelect conn $ limit 1 $ (liftIO $ runSelect conn $ limit 1 $
orderBy (desc (\(_, ts, _, _, _) -> ts)) $ orderBy (desc (\(_, ts, _, _, _) -> ts)) $
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<
queryTable amountTable queryTable amountTable
:: MateHandler
[ ( Int
, UTCTime
, Int
, Int
, Bool
)
]
) )
if realamount < amount if realamount < amount
then return (Just $ amount - realamount) then return (Just $ amount - realamount)
@ -199,20 +163,21 @@ postBuyProductAmountUpdate
-> MateHandler Int -> MateHandler Int
postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do postBuyProductAmountUpdate (PurchaseDetail pid pdamount) conn = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
(amount, oldprice) <- (\(_, _, am, op, _) -> (am, op)) . head <$> ( (amount, oldprice) <-
liftIO $ runSelect conn $ limit 1 $ (\am -> (amountAmount am, amountPrice am)) . fromDatabase . head <$> (
orderBy (desc (\(_, ts, _, _, _) -> ts)) $ liftIO $ runSelect conn $ limit 1 $
keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<< orderBy (desc (\(_, ts, _, _, _) -> ts)) $
queryTable amountTable keepWhen (\(id_, _, _, _, _) -> id_ .== C.constant pid) <<<
:: MateHandler queryTable amountTable
[ ( Int :: MateHandler
, UTCTime [ ( Int
, Int , UTCTime
, Int , Int
, Bool , Int
) , Bool
] )
) ]
)
liftIO $ head <$> runInsert_ conn (Insert liftIO $ head <$> runInsert_ conn (Insert
{ iTable = amountTable { iTable = amountTable
, iRows = , iRows =

View File

@ -39,6 +39,7 @@ import qualified Opaleye.Constant as C
import Types.Auth import Types.Auth
import Types.Reader import Types.Reader
import Classes
initToken :: PGS.Query initToken :: PGS.Query
@ -120,22 +121,12 @@ selectAuthOverviews
-> PGS.Connection -> PGS.Connection
-> MateHandler [AuthOverview] -> MateHandler [AuthOverview]
selectAuthOverviews uid conn = do selectAuthOverviews uid conn = do
authData <- liftIO $ runSelect conn (proc () -> do liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
(adid, aduid, admethod, adcomment, _) <- (adid, aduid, admethod, adcomment, _) <-
queryTable authDataTable -< () queryTable authDataTable -< ()
restrict -< aduid .== C.constant uid restrict -< aduid .== C.constant uid
returnA -< (adid, adcomment, admethod) returnA -< (adid, adcomment, admethod)
) :: MateHandler )
[ ( Int
, T.Text
, Int
)
]
return $ map
(\(adid, adcomment, admethod) ->
AuthOverview adid adcomment (toEnum admethod)
)
authData
getUserAuthInfo getUserAuthInfo
@ -144,24 +135,16 @@ getUserAuthInfo
-> PGS.Connection -> PGS.Connection
-> MateHandler AuthInfo -> MateHandler AuthInfo
getUserAuthInfo uid method conn = do getUserAuthInfo uid method conn = do
authdata <- map (\(aid, auid, amethod, acomment, apayload) -> authdata <-
(aid, auid, amethod, acomment, decodeUtf8 $ B64.encode apayload)) <$> liftIO $ do
liftIO (do
void $ threadDelay delayTime void $ threadDelay delayTime
runSelect conn (proc () -> do map fromDatabase <$> runSelect conn (proc () -> do
(aid, auid, amethod, acomment, apayload) <- (aid, auid, amethod, acomment, apayload) <-
queryTable authDataTable -< () queryTable authDataTable -< ()
restrict -< restrict -<
auid .== C.constant uid .&& amethod .== C.constant (fromEnum method) auid .== C.constant uid .&& amethod .== C.constant (fromEnum method)
returnA -< (aid, auid, amethod, acomment, apayload) returnA -< (aid, auid, amethod, acomment, apayload)
) :: IO ) :: IO [AuthData]
[ ( Int
, Int
, Int
, T.Text
, ByteString
)
])
if null authdata if null authdata
then then
-- generate mock AuthInfo -- generate mock AuthInfo
@ -215,21 +198,15 @@ validateToken
-> PGS.Connection -> PGS.Connection
-> Handler (Maybe (Int, AuthMethod)) -> Handler (Maybe (Int, AuthMethod))
validateToken header conn = do validateToken header conn = do
tokens <- liftIO $ runSelect conn ( tokens <- liftIO $ map fromDatabase <$> runSelect conn (
keepWhen (\(tstr, _, _, _) -> keepWhen (\(tstr, _, _, _) ->
tstr .== C.constant (decodeUtf8 header)) <<< queryTable tokenTable tstr .== C.constant (decodeUtf8 header)) <<< queryTable tokenTable
) :: Handler )
[ ( T.Text
, Int
, UTCTime
, Int
)
]
case tokens of case tokens of
[(_, uid, stamp, method)] -> do [(Token _ uid stamp method)] -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
if diffUTCTime stamp now > 0 if diffUTCTime stamp now > 0
then return $ Just (uid, toEnum method) then return $ Just (uid, method)
else do else do
void $ deleteToken (decodeUtf8 header) conn void $ deleteToken (decodeUtf8 header) conn
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
@ -249,22 +226,13 @@ generateToken
-> PGS.Connection -> PGS.Connection
-> MateHandler AuthResult -> MateHandler AuthResult
generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do generateToken (Ticket _ tuid _ (method, _)) (AuthResponse response) conn = do
authData <- liftIO $ runSelect conn ( authData <- liftIO $ map fromDatabase <$> runSelect conn (
keepWhen (\(_, auid, amethod, _, _) -> keepWhen (\(_, auid, amethod, _, _) ->
auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method)) auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method))
<<< queryTable authDataTable <<< queryTable authDataTable
) :: MateHandler ) :: MateHandler [AuthData]
[ ( Int
, Int
, Int
, T.Text
, ByteString
)
]
let userPayloads = map let userPayloads = map
(\(_, _, _, _, payload) -> authDataPayload
decodeUtf8 payload
)
authData authData
authResult = case method of authResult = case method of
PrimaryPass -> validatePass response userPayloads PrimaryPass -> validatePass response userPayloads

View File

@ -4,7 +4,8 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module Model.Product where module Model.Product where
import Data.Text as T hiding (head, foldl) import Data.Text (Text)
import qualified Data.Text as T hiding (head, foldl, map)
import Data.Time (getCurrentTime) import Data.Time (getCurrentTime)
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Data.Profunctor.Product (p9) import Data.Profunctor.Product (p9)
@ -23,6 +24,7 @@ import Opaleye.Constant as C
-- internal imports -- internal imports
import Types import Types
import Classes
import Model.Amount import Model.Amount
initProduct :: PGS.Query initProduct :: PGS.Query
@ -80,25 +82,9 @@ productSelect
:: PGS.Connection :: PGS.Connection
-> MateHandler [Product] -> MateHandler [Product]
productSelect conn = do productSelect conn = do
prods <- liftIO $ runSelect conn liftIO $ map fromDatabase <$> runSelect conn
( keepWhen (\_ -> C.constant True) <<< queryTable productTable ( keepWhen (\_ -> C.constant True) <<< queryTable productTable
) :: MateHandler )
[ ( Int
, T.Text
, Int
, Maybe Int
, Maybe Int
, Int
, Int
, Maybe Int
, Maybe T.Text
)
]
mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
Product i1 i2 i3 i4 i5 i6 i7 i8 i9
)
prods
productSelectSingle productSelectSingle

View File

@ -1,10 +1,17 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module Types.Amount where module Types.Amount where
import GHC.Generics import GHC.Generics
import Data.Aeson import Data.Aeson
import Data.Time (UTCTime)
-- internal imports
import Classes
data AmountUpdate = AmountUpdate data AmountUpdate = AmountUpdate
{ amountUpdateProductId :: Int { amountUpdateProductId :: Int
, amountUpdateRealAmount :: Int , amountUpdateRealAmount :: Int
@ -28,3 +35,27 @@ instance ToJSON AmountRefill where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AmountRefill instance FromJSON AmountRefill
data Amount = Amount
{ amountProductId :: Int
, amountTimestamp :: UTCTime
, amountAmount :: Int
, amountPrice :: Int
, amountVerified :: Bool
}
deriving (Show)
instance ToDatabase Amount where
type InTuple Amount = (Int, UTCTime, Int, Int, Bool)
toDatabase (Amount pid ts amount price ver) =
(pid, ts, amount, price, ver)
instance FromDatabase Amount where
type OutTuple Amount = (Int, UTCTime, Int, Int, Bool)
fromDatabase (pid, ts, amount, price, ver) =
Amount pid ts amount price ver

View File

@ -1,5 +1,6 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Types.Auth where module Types.Auth where
import GHC.Generics import GHC.Generics
@ -10,12 +11,18 @@ import qualified Data.Set as S
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as B64
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding
import Control.Concurrent.STM.TVar (TVar) import Control.Concurrent.STM.TVar (TVar)
-- internal imports -- internal imports
import Classes
data TicketRequest = TicketRequest data TicketRequest = TicketRequest
{ ticketRequestUser :: Int { ticketRequestUser :: Int
, ticketRequestMethod :: AuthMethod , ticketRequestMethod :: AuthMethod
@ -39,6 +46,20 @@ instance ToJSON AuthInfo where
instance FromJSON AuthInfo instance FromJSON AuthInfo
-- instance ToDatabase AuthInfo where
--
-- type InTuple AuthInfo = (Maybe T.Text, T.Text)
--
-- toDatabase (AuthInfo mChallenge (AuthTicket ticket)) =
-- (mChallenge, ticket)
instance FromDatabase AuthInfo where
type OutTuple AuthInfo = (Maybe T.Text, T.Text)
fromDatabase (mChallenge, ticket) =
AuthInfo mChallenge (AuthTicket ticket)
data AuthMethod data AuthMethod
= PrimaryPass = PrimaryPass
@ -122,6 +143,20 @@ data Token = Token
} }
deriving (Generic, Show) deriving (Generic, Show)
-- instance ToDatabase Token where
--
-- type InTuple Token = (T.Text, Int, UTCTime, Int)
--
-- toDatabase (Token string usr exp method) =
-- (string, usr, exp, fromEnum method)
instance FromDatabase Token where
type OutTuple Token = (T.Text, Int, UTCTime, Int)
fromDatabase (string, usr, exp, method) =
Token string usr exp (toEnum method)
type TicketStore = TVar (S.Set Ticket) type TicketStore = TVar (S.Set Ticket)
@ -147,6 +182,20 @@ data AuthData = AuthData
} }
deriving (Show) deriving (Show)
-- instance ToDatabase AuthData where
--
-- type InTuple AuthData = (Int, Int, Int, T.Text, ByteString)
--
-- toDatabase (AuthData id_ usr method comm payload) =
-- (id_, usr, fromEnum method, comm, (B64.decode $ encodeUtf8 payload))
instance FromDatabase AuthData where
type OutTuple AuthData = (Int, Int, Int, T.Text, ByteString)
fromDatabase (id_, usr, method, comm, payload) =
AuthData id_ usr (toEnum method) comm (decodeUtf8 $ B64.encode payload)
data AuthOverview = AuthOverview data AuthOverview = AuthOverview
{ authOverviewId :: Int { authOverviewId :: Int
@ -159,3 +208,17 @@ instance ToJSON AuthOverview where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthOverview instance FromJSON AuthOverview
-- instance ToDatabase AuthOverview where
--
-- type InTuple AuthOverview = (Int, T.Text, Int)
--
-- toDatabase (AuthOverview id_ comm method) =
-- (id_, comm, fromEnum method)
instance FromDatabase AuthOverview where
type OutTuple AuthOverview = (Int, T.Text, Int)
fromDatabase (id_, comm, method) =
AuthOverview id_ comm (toEnum method)

View File

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module Types.Product where module Types.Product where
import GHC.Generics import GHC.Generics
@ -7,6 +8,10 @@ import Data.Aeson
import qualified Data.Text as T import qualified Data.Text as T
-- internal imports
import Classes
data Product = Product data Product = Product
{ productId :: Int { productId :: Int
, productIdent :: T.Text , productIdent :: T.Text
@ -28,6 +33,22 @@ instance ToJSON Product where
instance FromJSON Product instance FromJSON Product
instance ToDatabase Product where
type InTuple Product =
(Int, T.Text, Int, Maybe Int, Maybe Int, Int, Int, Maybe Int, Maybe T.Text)
toDatabase (Product id_ ident ml maid msid maxa apc ppc artnr) =
(id_, ident, ml, maid, msid, maxa, apc, ppc, artnr)
instance FromDatabase Product where
type OutTuple Product =
(Int, T.Text, Int, Maybe Int, Maybe Int, Int, Int, Maybe Int, Maybe T.Text)
fromDatabase (id_, ident, ml, maid, msid, maxa, apc, ppc, artnr) =
Product id_ ident ml maid msid maxa apc ppc artnr
data ProductOverview = ProductOverview data ProductOverview = ProductOverview
{ productOverviewId :: Int { productOverviewId :: Int

View File

@ -5,6 +5,8 @@ module Types.Role where
import qualified Data.Text as T import qualified Data.Text as T
import Data.Aeson import Data.Aeson
import Data.Time (UTCTime)
import GHC.Generics import GHC.Generics
-- internal imports -- internal imports