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 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

View File

@ -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

View File

@ -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