225 lines
5 KiB
Haskell
225 lines
5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
module Model.User where
|
|
|
|
import Data.Text as T hiding (head, foldl)
|
|
import Data.Time.Calendar
|
|
import Data.Time.Clock
|
|
|
|
import Data.Profunctor.Product (p6)
|
|
|
|
import Data.Int (Int64)
|
|
|
|
import qualified Database.PostgreSQL.Simple as PGS
|
|
|
|
import Control.Arrow ((<<<))
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
import Opaleye as O
|
|
import qualified Opaleye.Constant as C
|
|
|
|
-- internal imports
|
|
|
|
import Types.User
|
|
import Types.Refine
|
|
import Types.Reader
|
|
|
|
initUser :: PGS.Query
|
|
initUser = mconcat
|
|
[ "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"
|
|
, ")"
|
|
]
|
|
|
|
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
|
|
( tableField "user_id"
|
|
, tableField "user_ident"
|
|
, tableField "user_balance"
|
|
, tableField "user_timestamp"
|
|
, tableField "user_email"
|
|
, tableField "user_avatar"
|
|
)
|
|
)
|
|
|
|
userSelect
|
|
:: UserRefine
|
|
-> PGS.Connection
|
|
-> MateHandler [UserSummary]
|
|
userSelect ref conn = do
|
|
today <- utctDay <$> liftIO getCurrentTime
|
|
users <- liftIO $ runSelect conn (
|
|
orderBy (asc (\(_, ident, _, _, _, _) -> ident)) (
|
|
keepWhen (\(_, _, _, ts, _, _) -> case ref of
|
|
AllUsers ->
|
|
C.constant True
|
|
ActiveUsers ->
|
|
ts .>= C.constant (addDays (-30) today)
|
|
OldUsers ->
|
|
ts .< C.constant (addDays (-30) today)
|
|
) <<< selectTable userTable)
|
|
) :: MateHandler
|
|
[ ( Int
|
|
, Text
|
|
, Int
|
|
, Day
|
|
, Maybe Text
|
|
, Maybe Int
|
|
)
|
|
]
|
|
mapM
|
|
(\(i1, i2, _, _, _, i6) -> return $
|
|
UserSummary i1 i2 i6
|
|
)
|
|
users
|
|
|
|
userDetailsSelect
|
|
:: Int
|
|
-> PGS.Connection
|
|
-> MateHandler UserDetails
|
|
userDetailsSelect uid conn = do
|
|
users <- liftIO $ runSelect conn (
|
|
keepWhen (\(uuid, _, _, _, _, _) ->
|
|
uuid .== C.constant uid
|
|
) <<< queryTable userTable
|
|
) :: MateHandler
|
|
[ ( Int
|
|
, Text
|
|
, Int
|
|
, Day
|
|
, Maybe Text
|
|
, Maybe Int
|
|
)
|
|
]
|
|
head <$> mapM
|
|
(\(i1, i2, i3, _, i5, i6) -> return $
|
|
UserDetails i1 i2 i3 i5 i6
|
|
)
|
|
users
|
|
|
|
|
|
userBalanceSelect
|
|
:: PGS.Connection
|
|
-> Int
|
|
-> MateHandler Int
|
|
userBalanceSelect conn uid = do
|
|
users <- liftIO $ 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
|
|
:: T.Text
|
|
-> Maybe T.Text
|
|
-> Day
|
|
-> PGS.Connection
|
|
-> MateHandler Int
|
|
insertUser ident email now conn = fmap head $ liftIO $ runInsert_ conn $ Insert
|
|
{ iTable = userTable
|
|
, iRows =
|
|
[
|
|
( C.constant (Nothing :: Maybe Int)
|
|
, C.constant ident
|
|
, C.constant (0 :: Int)
|
|
, C.constant now
|
|
, C.constant email
|
|
, C.constant (Nothing :: Maybe Int)
|
|
)
|
|
]
|
|
, iReturning = rReturning (\(uid, _, _, _, _, _) -> uid)
|
|
, iOnConflict = Nothing
|
|
}
|
|
|
|
updateUserDetails
|
|
:: Int
|
|
-> UserDetailsSubmit
|
|
-> Day
|
|
-> PGS.Connection
|
|
-> MateHandler Int64
|
|
updateUserDetails uid uds now conn = liftIO $ runUpdate_ conn $ Update
|
|
{ uTable = userTable
|
|
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _) ->
|
|
( id_
|
|
, C.constant (userDetailsSubmitIdent uds)
|
|
, i3
|
|
, C.constant now
|
|
, C.constant (userDetailsSubmitEmail uds)
|
|
, C.constant (userDetailsSubmitAvatar uds)
|
|
)
|
|
)
|
|
, uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid
|
|
, uReturning = rCount
|
|
}
|
|
|
|
updateUserTimestamp
|
|
:: Int
|
|
-> Day
|
|
-> PGS.Connection
|
|
-> MateHandler Int64
|
|
updateUserTimestamp uid now conn = liftIO $ runUpdate_ conn $ Update
|
|
{ uTable = userTable
|
|
, uUpdateWith = updateEasy (\(id_, ident, balance, _, email, ava) ->
|
|
( id_
|
|
, ident
|
|
, balance
|
|
, C.constant now
|
|
, email
|
|
, ava
|
|
)
|
|
)
|
|
, uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid
|
|
, uReturning = rCount
|
|
}
|
|
|
|
addToUserBalance
|
|
:: Int
|
|
-> Int
|
|
-> PGS.Connection
|
|
-> MateHandler Int64
|
|
addToUserBalance uid amount conn = liftIO $ runUpdate_ conn $ Update
|
|
{ uTable = userTable
|
|
, uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6) ->
|
|
( id_
|
|
, i2
|
|
, i3 + C.constant amount
|
|
, i4
|
|
, i5
|
|
, i6
|
|
)
|
|
)
|
|
, uWhere = \(i1, _, _, _, _, _) -> i1 .== C.constant uid
|
|
, uReturning = rCount
|
|
}
|