From dd58c372cf6711d268cf93559a0fbdad7817c2fa Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 27 Aug 2020 10:28:27 +0200 Subject: [PATCH] more instances of ToDatabase and FromDatabase --- src/Model/Product.hs | 46 +++++++++++++++++--------------------------- src/Model/User.hs | 46 ++++++++++---------------------------------- src/Types/User.hs | 17 ++++++++++++++++ 3 files changed, 45 insertions(+), 64 deletions(-) diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 157f54b..eea9159 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -6,10 +6,13 @@ module Model.Product where 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) +import Data.Maybe + import Control.Monad.IO.Class (liftIO) import Control.Arrow @@ -83,37 +86,23 @@ productSelect -> MateHandler [Product] productSelect conn = do liftIO $ map fromDatabase <$> runSelect conn - ( keepWhen (\_ -> C.constant True) <<< queryTable productTable - ) + (queryTable productTable) productSelectSingle :: Int -> PGS.Connection - -> MateHandler [Product] + -> MateHandler (Maybe Product) productSelectSingle pid conn = do - prods <- liftIO $ runSelect conn + prods <- liftIO $ map fromDatabase <$> runSelect conn ( limit 1 (keepWhen ( \(id_, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid ) <<< 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 + ) + case prods of + p:_ -> return (Just p) + _ -> return Nothing productOverviewSelect @@ -193,12 +182,13 @@ produceProductOverviews refine = queryAmounts :: PGS.Connection -> Int - -> IO [(Int, UTCTime, Int, Int, Bool)] -queryAmounts conn pid = runSelect conn $ proc () -> do + -> IO [Amount] +queryAmounts conn pid = map fromDatabase <$> runSelect conn (proc () -> do stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts)) (queryTable amountTable) -< () restrict -< C.constant pid .== a1 returnA -< stuff + ) generateProductOverview :: PGS.Connection @@ -219,14 +209,14 @@ generateProductOverview conn (i1, i2, i3, i4, i5, i6, i7, i8, i9, a3, a4) = do amounts <- liftIO $ queryAmounts conn i1 let ii5 = snd $ foldl - (\(bef, van) (_, _, amo, _, ver) -> + (\(bef, van) (Amount _ _ amo _ ver) -> if ver then (amo, if amo < bef then van + (bef - amo) else van) else (amo, van) ) (0, 0) - (Prelude.reverse amounts) - ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) -> + (reverse amounts) + ii10 = snd $ foldl (\(bef, tot) (Amount _ _ amo _ ver) -> if ver then (amo, tot) else (amo, tot + Prelude.max 0 (bef - amo)) @@ -307,7 +297,7 @@ manualProductAmountRefill aups conn = (\(AmountRefill pid amountSingles amountCrates) -> do oldamount <- getLatestAmountByProductId pid conn oldprice <- getLatestPriceByProductId pid conn - perCrate <- productAmountPerCrate . head <$> + perCrate <- productAmountPerCrate . fromJust <$> productSelectSingle pid conn head <$> liftIO (do now <- getCurrentTime diff --git a/src/Model/User.hs b/src/Model/User.hs index 36695fa..d22d538 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Model.User where -import Data.Text as T hiding (head, foldl) +import qualified Data.Text as T import Data.Time.Calendar import Data.Time.Clock @@ -23,6 +23,7 @@ import qualified Opaleye.Constant as C import Types.User import Types.Refine import Types.Reader +import Classes initUser :: PGS.Query initUser = mconcat @@ -68,7 +69,7 @@ userSelect -> MateHandler [UserSummary] userSelect ref conn = do today <- utctDay <$> liftIO getCurrentTime - users <- liftIO $ runSelect conn ( + users <- liftIO $ map fromDatabase <$> runSelect conn ( orderBy (asc (\(_, ident, _, _, _, _) -> ident)) ( keepWhen (\(_, _, _, ts, _, _) -> case ref of AllUsers -> @@ -78,17 +79,9 @@ userSelect ref conn = do OldUsers -> ts .< C.constant (addDays (-30) today) ) <<< selectTable userTable) - ) :: MateHandler - [ ( Int - , Text - , Int - , Day - , Maybe Text - , Maybe Int - ) - ] + ) :: MateHandler [User] mapM - (\(i1, i2, _, _, _, i6) -> return $ + (\(User i1 i2 _ _ _ i6) -> return $ UserSummary i1 i2 i6 ) users @@ -98,21 +91,13 @@ userDetailsSelect -> PGS.Connection -> MateHandler UserDetails userDetailsSelect uid conn = do - users <- liftIO $ runSelect conn ( + users <- liftIO $ map fromDatabase <$> runSelect conn ( keepWhen (\(uuid, _, _, _, _, _) -> uuid .== C.constant uid ) <<< queryTable userTable - ) :: MateHandler - [ ( Int - , Text - , Int - , Day - , Maybe Text - , Maybe Int - ) - ] + ) :: MateHandler [User] head <$> mapM - (\(i1, i2, i3, _, i5, i6) -> return $ + (\(User i1 i2 i3 _ i5 i6) -> return $ UserDetails i1 i2 i3 i5 i6 ) users @@ -123,22 +108,11 @@ userBalanceSelect -> Int -> MateHandler Int userBalanceSelect conn uid = do - users <- liftIO $ runSelect conn ( + liftIO $ userBalance . fromDatabase . head <$> runSelect conn ( keepWhen (\(uuid, _, _, _, _, _) -> uuid .== C.constant uid ) <<< queryTable userTable - ) :: MateHandler - [ ( Int - , Text - , Int - , Day - , Maybe Text - , Maybe Int - ) - ] - head <$> mapM - (\(_, _, i3, _, _, _) -> return i3) - users + ) insertUser diff --git a/src/Types/User.hs b/src/Types/User.hs index 136e327..2d5d64b 100644 --- a/src/Types/User.hs +++ b/src/Types/User.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} module Types.User where import GHC.Generics @@ -11,6 +12,8 @@ import qualified Data.Text as T -- internal imports +import Classes + data User = User { userId :: Int @@ -25,6 +28,20 @@ data User } deriving (Generic, Show) +instance ToDatabase User where + + type InTuple User = (Int, T.Text, Int, Day, Maybe T.Text, Maybe Int) + + toDatabase (User id_ ident bal ts email ava) = + (id_, ident, bal, ts, email, ava) + +instance FromDatabase User where + + type OutTuple User = (Int, T.Text, Int, Day, Maybe T.Text, Maybe Int) + + fromDatabase (id_, ident, bal, ts, email, ava) = + (User id_ ident bal ts email ava) + data UserSummary = UserSummary { userSummaryId :: Int