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