mateamt/src/Model/User.hs

214 lines
4.9 KiB
Haskell
Raw Permalink Normal View History

2019-04-15 20:23:25 +00:00
{-# LANGUAGE OverloadedStrings #-}
2022-04-17 10:44:27 +00:00
{-# LANGUAGE Arrows #-}
2019-04-15 20:23:25 +00:00
module Model.User where
import qualified Data.Text as T
2019-04-15 20:23:25 +00:00
import Data.Time.Calendar
import Data.Time.Clock
2019-04-21 15:27:15 +00:00
import Data.Profunctor.Product (p6)
2019-04-15 20:23:25 +00:00
2019-04-17 14:14:44 +00:00
import Data.Int (Int64)
2019-04-15 20:23:25 +00:00
import qualified Database.PostgreSQL.Simple as PGS
2022-04-17 10:44:27 +00:00
import Control.Arrow
2019-04-15 20:23:25 +00:00
2019-05-09 14:53:19 +00:00
import Control.Monad.IO.Class (liftIO)
2019-04-15 20:23:25 +00:00
import Opaleye as O
-- internal imports
2019-04-17 14:14:44 +00:00
import Types.User
2019-04-17 05:51:15 +00:00
import Types.Refine
2019-05-09 14:53:19 +00:00
import Types.Reader
import Classes
2019-04-17 05:51:15 +00:00
2019-04-16 11:03:07 +00:00
initUser :: PGS.Query
2019-07-21 14:05:05 +00:00
initUser = mconcat
2019-08-10 09:43:33 +00:00
[ "CREATE TABLE IF NOT EXISTS \"user\" ("
, "user_id SERIAL PRIMARY KEY,"
, "user_ident TEXT NOT NULL,"
, "user_balance INTEGER NOT NULL,"
, "user_timestamp DATE NOT NULL,"
, "user_email TEXT,"
, "user_avatar INTEGER REFERENCES \"avatar\"(\"avatar_id\") ON DELETE CASCADE"
2019-07-21 13:02:59 +00:00
, ")"
]
2019-04-16 11:03:07 +00:00
2019-04-15 20:23:25 +00:00
userTable :: Table
( Maybe (Field SqlInt4)
, Field SqlText
, Field SqlInt4
, Field SqlDate
, FieldNullable SqlText
, FieldNullable SqlInt4
)
( Field SqlInt4
, Field SqlText
, Field SqlInt4
, Field SqlDate
, FieldNullable SqlText
, FieldNullable SqlInt4
)
userTable = table "user" (
p6
2019-04-21 15:27:15 +00:00
( tableField "user_id"
, tableField "user_ident"
, tableField "user_balance"
, tableField "user_timestamp"
, tableField "user_email"
, tableField "user_avatar"
2019-04-15 20:23:25 +00:00
)
)
userSelect
:: UserRefine
2022-07-24 23:31:16 +00:00
-> Int
2019-09-06 19:44:47 +00:00
-> PGS.Connection
2019-09-09 10:54:56 +00:00
-> MateHandler [UserSummary]
2022-07-24 23:31:16 +00:00
userSelect ref idleTime conn = do
2019-10-14 21:34:45 +00:00
today <- utctDay <$> liftIO getCurrentTime
2022-04-17 10:44:27 +00:00
users <- liftIO $ map fromDatabase <$> runSelect conn ( proc () -> do
stuff@(_, _, _, ts, _, _) <- orderBy (asc (\(_, ident, _, _, _, _) -> ident))
(selectTable userTable) -< ()
restrict -< case ref of
2019-10-31 23:00:41 +00:00
AllUsers ->
2021-07-14 01:08:58 +00:00
toFields True
2019-10-31 23:00:41 +00:00
ActiveUsers ->
2022-07-24 23:31:16 +00:00
ts .>= toFields (addDays (- (fromIntegral idleTime)) today)
2019-10-31 23:00:41 +00:00
OldUsers ->
2022-07-24 23:31:16 +00:00
ts .< toFields (addDays (- (fromIntegral idleTime)) today)
2022-04-17 10:44:27 +00:00
returnA -< stuff
) :: MateHandler [User]
2019-04-17 05:51:15 +00:00
mapM
(\(User i1 i2 _ _ _ i6) -> return $
2019-09-09 10:54:56 +00:00
UserSummary i1 i2 i6
2019-04-15 20:23:25 +00:00
)
2019-04-17 05:51:15 +00:00
users
2019-04-15 20:23:25 +00:00
2022-02-20 20:48:16 +00:00
userDetailsSelectAll
:: PGS.Connection
-> MateHandler [UserDetails]
userDetailsSelectAll conn = do
users <- liftIO (map fromDatabase <$> runSelect conn (selectTable userTable)) :: MateHandler [User]
return $ map
(\(User i1 i2 i3 _ i5 i6) ->
UserDetails i1 i2 i3 i5 i6
)
users
2019-05-16 16:37:04 +00:00
userDetailsSelect
2019-09-06 19:44:47 +00:00
:: Int
-> PGS.Connection
2019-05-16 16:37:04 +00:00
-> MateHandler UserDetails
2019-09-07 00:48:16 +00:00
userDetailsSelect uid conn = do
2022-04-17 10:44:27 +00:00
users <- liftIO $ map fromDatabase <$> runSelect conn (proc () -> do
stuff@(uuid, _, _, _, _, _) <- limit 1 (selectTable userTable) -< ()
restrict -< uuid .== toFields uid
returnA -< stuff
) :: MateHandler [User]
2019-05-16 16:37:04 +00:00
head <$> mapM
(\(User i1 i2 i3 _ i5 i6) -> return $
UserDetails i1 i2 i3 i5 i6
2019-05-16 16:37:04 +00:00
)
users
2019-07-20 16:36:47 +00:00
userBalanceSelect
:: PGS.Connection
-> Int
-> MateHandler Int
2019-09-07 00:48:16 +00:00
userBalanceSelect conn uid = do
2022-04-17 10:44:27 +00:00
liftIO $ userBalance . fromDatabase . head <$> runSelect conn (proc () -> do
stuff@(uuid, _, _, _, _, _) <- selectTable userTable -< ()
restrict -< uuid .== toFields uid
returnA -< stuff
)
2019-07-20 16:36:47 +00:00
2019-07-28 09:55:22 +00:00
insertUser
:: T.Text
-> Maybe T.Text
2019-07-28 09:55:22 +00:00
-> Day
-> PGS.Connection
-> MateHandler Int
2022-04-17 10:44:27 +00:00
insertUser ident email now_ conn = fmap head $ liftIO $ runInsert_ conn $ Insert
2019-04-15 20:23:25 +00:00
{ iTable = userTable
, iRows =
[
2021-07-14 01:08:58 +00:00
( toFields (Nothing :: Maybe Int)
, toFields ident
, toFields (0 :: Int)
2022-04-17 10:44:27 +00:00
, toFields now_
2021-07-14 01:08:58 +00:00
, toFields email
, toFields (Nothing :: Maybe Int)
2019-04-15 20:23:25 +00:00
)
]
, iReturning = rReturning (\(uid, _, _, _, _, _) -> uid)
2019-04-15 20:23:25 +00:00
, iOnConflict = Nothing
2019-04-16 04:23:08 +00:00
}
2019-07-28 09:55:22 +00:00
updateUserDetails
:: Int
-> UserDetailsSubmit
-> Day
-> PGS.Connection
-> MateHandler Int64
2022-04-17 10:44:27 +00:00
updateUserDetails uid uds now_ conn = liftIO $ runUpdate_ conn $ Update
2019-07-20 16:36:47 +00:00
{ uTable = userTable
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _) ->
2019-04-16 04:23:08 +00:00
( id_
2021-07-14 01:08:58 +00:00
, toFields (userDetailsSubmitIdent uds)
, i3
2022-04-17 10:44:27 +00:00
, toFields now_
2021-07-14 01:08:58 +00:00
, toFields (userDetailsSubmitEmail uds)
, toFields (userDetailsSubmitAvatar uds)
2019-04-16 04:23:08 +00:00
)
)
2021-07-14 01:08:58 +00:00
, uWhere = \(i1, _, _, _, _, _) -> i1 .== toFields uid
2019-07-20 16:36:47 +00:00
, uReturning = rCount
}
2019-12-26 08:26:32 +00:00
updateUserTimestamp
:: Int
-> Day
-> PGS.Connection
-> MateHandler Int64
2022-04-17 10:44:27 +00:00
updateUserTimestamp uid now_ conn = liftIO $ runUpdate_ conn $ Update
2019-12-26 08:26:32 +00:00
{ uTable = userTable
, uUpdateWith = updateEasy (\(id_, ident, balance, _, email, ava) ->
( id_
, ident
, balance
2022-04-17 10:44:27 +00:00
, toFields now_
2019-12-26 08:26:32 +00:00
, email
, ava
)
)
2021-07-14 01:08:58 +00:00
, uWhere = \(i1, _, _, _, _, _) -> i1 .== toFields uid
2019-12-26 08:26:32 +00:00
, uReturning = rCount
}
2019-07-20 16:36:47 +00:00
addToUserBalance
:: Int
-> Int
2019-07-28 09:55:22 +00:00
-> PGS.Connection
-> MateHandler Int64
addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update
2019-07-20 16:36:47 +00:00
{ uTable = userTable
, uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6) ->
2019-07-20 16:36:47 +00:00
( id_
, i2
2021-07-14 01:08:58 +00:00
, i3 + toFields amount
2019-07-20 16:36:47 +00:00
, i4
, i5
, i6
)
)
2021-07-14 01:08:58 +00:00
, uWhere = \(i1, _, _, _, _, _) -> i1 .== toFields uid
2019-07-20 16:36:47 +00:00
, uReturning = rCount
2019-04-16 04:23:08 +00:00
}