From 3d2971baa37ea7522634cd8508c39a0506ce2470 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 26 Aug 2020 21:29:39 +0200 Subject: [PATCH] make more instances of ToDatabase and FromDatabase --- src/Model/Amount.hs | 95 ++++++++++++++------------------------------ src/Model/Auth.hs | 60 +++++++--------------------- src/Model/Product.hs | 24 +++-------- src/Types/Amount.hs | 31 +++++++++++++++ src/Types/Auth.hs | 63 +++++++++++++++++++++++++++++ src/Types/Product.hs | 21 ++++++++++ src/Types/Role.hs | 2 + 7 files changed, 166 insertions(+), 130 deletions(-) diff --git a/src/Model/Amount.hs b/src/Model/Amount.hs index d7bc776..d9f47e3 100644 --- a/src/Model/Amount.hs +++ b/src/Model/Amount.hs @@ -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 = diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index e077506..e5c3480 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -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 diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 8698b01..157f54b 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -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 diff --git a/src/Types/Amount.hs b/src/Types/Amount.hs index 3bdb49e..8b164ba 100644 --- a/src/Types/Amount.hs +++ b/src/Types/Amount.hs @@ -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 diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index fc21e23..d10a14a 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -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) diff --git a/src/Types/Product.hs b/src/Types/Product.hs index 2beff65..202aaae 100644 --- a/src/Types/Product.hs +++ b/src/Types/Product.hs @@ -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 diff --git a/src/Types/Role.hs b/src/Types/Role.hs index 7dbe2e9..c0ae7b1 100644 --- a/src/Types/Role.hs +++ b/src/Types/Role.hs @@ -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