more instances of ToDatabase and FromDatabase

This commit is contained in:
nek0 2020-08-27 10:28:27 +02:00
parent 3d2971baa3
commit dd58c372cf
3 changed files with 45 additions and 64 deletions

View file

@ -6,10 +6,13 @@ module Model.Product where
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T hiding (head, foldl, map) 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.Profunctor.Product (p9) import Data.Profunctor.Product (p9)
import Data.Maybe
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Arrow import Control.Arrow
@ -83,37 +86,23 @@ productSelect
-> MateHandler [Product] -> MateHandler [Product]
productSelect conn = do productSelect conn = do
liftIO $ map fromDatabase <$> runSelect conn liftIO $ map fromDatabase <$> runSelect conn
( keepWhen (\_ -> C.constant True) <<< queryTable productTable (queryTable productTable)
)
productSelectSingle productSelectSingle
:: Int :: Int
-> PGS.Connection -> PGS.Connection
-> MateHandler [Product] -> MateHandler (Maybe Product)
productSelectSingle pid conn = do productSelectSingle pid conn = do
prods <- liftIO $ runSelect conn prods <- liftIO $ map fromDatabase <$> runSelect conn
( limit 1 ( limit 1
(keepWhen ( (keepWhen (
\(id_, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid \(id_, _, _, _, _, _, _, _, _) -> id_ .== C.constant pid
) <<< queryTable productTable) ) <<< queryTable productTable)
) :: MateHandler
[ ( Int
, T.Text
, Int
, Maybe Int
, Maybe Int
, Int
, Int
, Maybe Int
, Maybe T.Text
) )
] case prods of
mapM p:_ -> return (Just p)
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $ _ -> return Nothing
Product i1 i2 i3 i4 i5 i6 i7 i8 i9
)
prods
productOverviewSelect productOverviewSelect
@ -193,12 +182,13 @@ produceProductOverviews refine =
queryAmounts queryAmounts
:: PGS.Connection :: PGS.Connection
-> Int -> Int
-> IO [(Int, UTCTime, Int, Int, Bool)] -> IO [Amount]
queryAmounts conn pid = runSelect conn $ proc () -> do queryAmounts conn pid = map fromDatabase <$> runSelect conn (proc () -> do
stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts)) stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
(queryTable amountTable) -< () (queryTable amountTable) -< ()
restrict -< C.constant pid .== a1 restrict -< C.constant pid .== a1
returnA -< stuff returnA -< stuff
)
generateProductOverview generateProductOverview
:: PGS.Connection :: 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 amounts <- liftIO $ queryAmounts conn i1
let ii5 = snd $ let ii5 = snd $
foldl foldl
(\(bef, van) (_, _, amo, _, ver) -> (\(bef, van) (Amount _ _ amo _ ver) ->
if ver if ver
then (amo, if amo < bef then van + (bef - amo) else van) then (amo, if amo < bef then van + (bef - amo) else van)
else (amo, van) else (amo, van)
) )
(0, 0) (0, 0)
(Prelude.reverse amounts) (reverse amounts)
ii10 = snd $ foldl (\(bef, tot) (_, _, amo, _, ver) -> ii10 = snd $ foldl (\(bef, tot) (Amount _ _ amo _ ver) ->
if ver if ver
then (amo, tot) then (amo, tot)
else (amo, tot + Prelude.max 0 (bef - amo)) else (amo, tot + Prelude.max 0 (bef - amo))
@ -307,7 +297,7 @@ manualProductAmountRefill aups conn =
(\(AmountRefill pid amountSingles amountCrates) -> do (\(AmountRefill pid amountSingles amountCrates) -> do
oldamount <- getLatestAmountByProductId pid conn oldamount <- getLatestAmountByProductId pid conn
oldprice <- getLatestPriceByProductId pid conn oldprice <- getLatestPriceByProductId pid conn
perCrate <- productAmountPerCrate . head <$> perCrate <- productAmountPerCrate . fromJust <$>
productSelectSingle pid conn productSelectSingle pid conn
head <$> liftIO (do head <$> liftIO (do
now <- getCurrentTime now <- getCurrentTime

View file

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Model.User where 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.Calendar
import Data.Time.Clock import Data.Time.Clock
@ -23,6 +23,7 @@ import qualified Opaleye.Constant as C
import Types.User import Types.User
import Types.Refine import Types.Refine
import Types.Reader import Types.Reader
import Classes
initUser :: PGS.Query initUser :: PGS.Query
initUser = mconcat initUser = mconcat
@ -68,7 +69,7 @@ userSelect
-> MateHandler [UserSummary] -> MateHandler [UserSummary]
userSelect ref conn = do userSelect ref conn = do
today <- utctDay <$> liftIO getCurrentTime today <- utctDay <$> liftIO getCurrentTime
users <- liftIO $ runSelect conn ( users <- liftIO $ map fromDatabase <$> runSelect conn (
orderBy (asc (\(_, ident, _, _, _, _) -> ident)) ( orderBy (asc (\(_, ident, _, _, _, _) -> ident)) (
keepWhen (\(_, _, _, ts, _, _) -> case ref of keepWhen (\(_, _, _, ts, _, _) -> case ref of
AllUsers -> AllUsers ->
@ -78,17 +79,9 @@ userSelect ref conn = do
OldUsers -> OldUsers ->
ts .< C.constant (addDays (-30) today) ts .< C.constant (addDays (-30) today)
) <<< selectTable userTable) ) <<< selectTable userTable)
) :: MateHandler ) :: MateHandler [User]
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
)
]
mapM mapM
(\(i1, i2, _, _, _, i6) -> return $ (\(User i1 i2 _ _ _ i6) -> return $
UserSummary i1 i2 i6 UserSummary i1 i2 i6
) )
users users
@ -98,21 +91,13 @@ userDetailsSelect
-> PGS.Connection -> PGS.Connection
-> MateHandler UserDetails -> MateHandler UserDetails
userDetailsSelect uid conn = do userDetailsSelect uid conn = do
users <- liftIO $ runSelect conn ( users <- liftIO $ map fromDatabase <$> runSelect conn (
keepWhen (\(uuid, _, _, _, _, _) -> keepWhen (\(uuid, _, _, _, _, _) ->
uuid .== C.constant uid uuid .== C.constant uid
) <<< queryTable userTable ) <<< queryTable userTable
) :: MateHandler ) :: MateHandler [User]
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
)
]
head <$> mapM head <$> mapM
(\(i1, i2, i3, _, i5, i6) -> return $ (\(User i1 i2 i3 _ i5 i6) -> return $
UserDetails i1 i2 i3 i5 i6 UserDetails i1 i2 i3 i5 i6
) )
users users
@ -123,22 +108,11 @@ userBalanceSelect
-> Int -> Int
-> MateHandler Int -> MateHandler Int
userBalanceSelect conn uid = do userBalanceSelect conn uid = do
users <- liftIO $ runSelect conn ( liftIO $ userBalance . fromDatabase . head <$> runSelect conn (
keepWhen (\(uuid, _, _, _, _, _) -> keepWhen (\(uuid, _, _, _, _, _) ->
uuid .== C.constant uid uuid .== C.constant uid
) <<< queryTable userTable ) <<< queryTable userTable
) :: MateHandler
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
) )
]
head <$> mapM
(\(_, _, i3, _, _, _) -> return i3)
users
insertUser insertUser

View file

@ -1,4 +1,5 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module Types.User where module Types.User where
import GHC.Generics import GHC.Generics
@ -11,6 +12,8 @@ import qualified Data.Text as T
-- internal imports -- internal imports
import Classes
data User data User
= User = User
{ userId :: Int { userId :: Int
@ -25,6 +28,20 @@ data User
} }
deriving (Generic, Show) 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 data UserSummary = UserSummary
{ userSummaryId :: Int { userSummaryId :: Int