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

View file

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

View file

@ -4,7 +4,8 @@
{-# LANGUAGE ScopedTypeVariables #-}
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.Clock (UTCTime)
import Data.Profunctor.Product (p9)
@ -23,6 +24,7 @@ import Opaleye.Constant as C
-- internal imports
import Types
import Classes
import Model.Amount
initProduct :: PGS.Query
@ -80,25 +82,9 @@ productSelect
:: PGS.Connection
-> MateHandler [Product]
productSelect conn = do
prods <- liftIO $ runSelect conn
liftIO $ map fromDatabase <$> runSelect conn
( 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

View file

@ -1,10 +1,17 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module Types.Amount where
import GHC.Generics
import Data.Aeson
import Data.Time (UTCTime)
-- internal imports
import Classes
data AmountUpdate = AmountUpdate
{ amountUpdateProductId :: Int
, amountUpdateRealAmount :: Int
@ -28,3 +35,27 @@ instance ToJSON AmountRefill where
toEncoding = genericToEncoding defaultOptions
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 TypeSynonymInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Types.Auth where
import GHC.Generics
@ -10,12 +11,18 @@ import qualified Data.Set as S
import Data.Time.Clock (UTCTime)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base64 as B64
import qualified Data.Text as T
import Data.Text.Encoding
import Control.Concurrent.STM.TVar (TVar)
-- internal imports
import Classes
data TicketRequest = TicketRequest
{ ticketRequestUser :: Int
, ticketRequestMethod :: AuthMethod
@ -39,6 +46,20 @@ instance ToJSON AuthInfo where
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
= PrimaryPass
@ -122,6 +143,20 @@ data Token = Token
}
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)
@ -147,6 +182,20 @@ data AuthData = AuthData
}
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
{ authOverviewId :: Int
@ -159,3 +208,17 @@ instance ToJSON AuthOverview where
toEncoding = genericToEncoding defaultOptions
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 TypeFamilies #-}
module Types.Product where
import GHC.Generics
@ -7,6 +8,10 @@ import Data.Aeson
import qualified Data.Text as T
-- internal imports
import Classes
data Product = Product
{ productId :: Int
, productIdent :: T.Text
@ -28,6 +33,22 @@ instance ToJSON Product where
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
{ productOverviewId :: Int

View file

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