further modernisation

This commit is contained in:
nek0 2022-04-17 12:44:27 +02:00
parent 26e4473c30
commit f829d14384

View file

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Arrows #-}
module Model.User where
import qualified Data.Text as T
@ -11,7 +12,7 @@ import Data.Int (Int64)
import qualified Database.PostgreSQL.Simple as PGS
import Control.Arrow ((<<<))
import Control.Arrow
import Control.Monad.IO.Class (liftIO)
@ -68,16 +69,17 @@ userSelect
-> MateHandler [UserSummary]
userSelect ref conn = do
today <- utctDay <$> liftIO getCurrentTime
users <- liftIO $ map fromDatabase <$> runSelect conn (
orderBy (asc (\(_, ident, _, _, _, _) -> ident)) (
keepWhen (\(_, _, _, ts, _, _) -> case ref of
users <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do
stuff@(_, _, _, ts, _, _) <- orderBy (asc (\(_, ident, _, _, _, _) -> ident))
(selectTable userTable) -< ()
restrict -< case ref of
AllUsers ->
toFields True
ActiveUsers ->
ts .>= toFields (addDays (-30) today)
OldUsers ->
ts .< toFields (addDays (-30) today)
) <<< selectTable userTable)
returnA -< stuff
) :: MateHandler [User]
mapM
(\(User i1 i2 _ _ _ i6) -> return $
@ -102,10 +104,10 @@ userDetailsSelect
-> PGS.Connection
-> MateHandler UserDetails
userDetailsSelect uid conn = do
users <- liftIO $ map fromDatabase <$> runSelect conn (limit 1 $
keepWhen (\(uuid, _, _, _, _, _) ->
uuid .== toFields uid
) <<< selectTable userTable
users <- liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
stuff@(uuid, _, _, _, _, _) <- limit 1 (selectTable userTable) -< ()
restrict -< uuid .== toFields uid
returnA -< stuff
) :: MateHandler [User]
head <$> mapM
(\(User i1 i2 i3 _ i5 i6) -> return $
@ -119,10 +121,10 @@ userBalanceSelect
-> Int
-> MateHandler Int
userBalanceSelect conn uid = do
liftIO $ userBalance . fromDatabase . head <$> runSelect conn (
keepWhen (\(uuid, _, _, _, _, _) ->
uuid .== toFields uid
) <<< selectTable userTable
liftIO $ userBalance . fromDatabase . head <$> runSelect conn (proc () -> do
stuff@(uuid, _, _, _, _, _) <- selectTable userTable -< ()
restrict -< uuid .== toFields uid
returnA -< stuff
)
@ -132,14 +134,14 @@ insertUser
-> Day
-> PGS.Connection
-> MateHandler Int
insertUser ident email now conn = fmap head $ liftIO $ runInsert_ conn $ Insert
insertUser ident email now_ conn = fmap head $ liftIO $ runInsert_ conn $ Insert
{ iTable = userTable
, iRows =
[
( toFields (Nothing :: Maybe Int)
, toFields ident
, toFields (0 :: Int)
, toFields now
, toFields now_
, toFields email
, toFields (Nothing :: Maybe Int)
)
@ -154,13 +156,13 @@ updateUserDetails
-> Day
-> PGS.Connection
-> MateHandler Int64
updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update
updateUserDetails uid uds now_ conn = liftIO $ runUpdate_ conn $ Update
{ uTable = userTable
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _) ->
( id_
, toFields (userDetailsSubmitIdent uds)
, i3
, toFields now
, toFields now_
, toFields (userDetailsSubmitEmail uds)
, toFields (userDetailsSubmitAvatar uds)
)
@ -174,13 +176,13 @@ updateUserTimestamp
-> Day
-> PGS.Connection
-> MateHandler Int64
updateUserTimestamp uid now conn = liftIO $ runUpdate_ conn $ Update
updateUserTimestamp uid now_ conn = liftIO $ runUpdate_ conn $ Update
{ uTable = userTable
, uUpdateWith = updateEasy (\(id_, ident, balance, _, email, ava) ->
( id_
, ident
, balance
, toFields now
, toFields now_
, email
, ava
)