mateamt/src/Model/User.hs

224 lines
5.5 KiB
Haskell
Raw Normal View History

2019-04-15 20:23:25 +00:00
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
2019-04-17 05:51:15 +00:00
{-# LANGUAGE DuplicateRecordFields #-}
2019-04-15 20:23:25 +00:00
module Model.User where
2019-04-17 08:45:48 +00:00
import Data.Text as T hiding (head)
2019-04-15 20:23:25 +00:00
import Data.Time.Calendar
import Data.Time.Clock
2019-04-21 15:27:15 +00:00
2019-04-17 08:45:48 +00:00
import Data.Profunctor.Product (p9)
2019-04-15 20:23:25 +00:00
2019-04-17 14:14:44 +00:00
import Data.Maybe (fromJust, isJust, fromMaybe)
2019-04-17 08:45:48 +00:00
import Data.ByteString hiding (head)
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
import GHC.Generics
import Control.Arrow ((<<<))
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
import qualified Opaleye.Constant as C
-- 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-04-17 08:45:48 +00:00
import Types.Auth
2019-05-09 14:53:19 +00:00
import Types.Reader
2019-04-17 05:51:15 +00:00
2019-04-16 11:03:07 +00:00
initUser :: PGS.Query
2019-04-21 15:27:15 +00:00
initUser = "create table if not exists \"user\" (user_id serial primary key, user_ident varchar(128) not null, user_balance integer not null, user_timestamp date not null, user_email varchar(128), user_avatar integer, user_salt bytea not null, user_hash bytea, user_algo integer)"
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
2019-04-17 08:45:48 +00:00
, Field SqlBytea
, FieldNullable SqlBytea
, FieldNullable SqlInt4
2019-04-15 20:23:25 +00:00
)
( Field SqlInt4
, Field SqlText
, Field SqlInt4
, Field SqlDate
, FieldNullable SqlText
, FieldNullable SqlInt4
2019-04-17 08:45:48 +00:00
, Field SqlBytea
, FieldNullable SqlBytea
, FieldNullable SqlInt4
2019-04-15 20:23:25 +00:00
)
userTable = table "user" (
2019-04-17 08:45:48 +00:00
p9
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"
, tableField "user_salt"
, tableField "user_hash"
, tableField "user_algo"
2019-04-15 20:23:25 +00:00
)
)
userSelect
:: PGS.Connection
-> Maybe Refine
2019-05-09 14:53:19 +00:00
-> MateHandler [User]
userSelect conn ref = do
2019-05-09 14:53:19 +00:00
today <- utctDay <$> (liftIO $ getCurrentTime)
users <- liftIO $ runSelect conn (case ref of
2019-04-17 08:45:48 +00:00
Nothing -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
2019-04-15 20:23:25 +00:00
ts .>= C.constant (addDays (-30) today)
) <<< queryTable userTable
Just All -> selectTable userTable
2019-04-17 08:45:48 +00:00
Just Old -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
2019-04-15 20:23:25 +00:00
ts .<= C.constant (addDays (-30) today)
) <<< queryTable userTable
2019-05-09 14:53:19 +00:00
) :: MateHandler
2019-04-17 08:45:48 +00:00
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
2019-04-17 05:51:15 +00:00
mapM
2019-04-17 08:45:48 +00:00
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
2019-05-13 20:50:24 +00:00
User i1 i2 i3 i4 i5 i6 (AuthSalt i7) (AuthHash <$> i8) (toEnum <$> i9)
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
2019-05-16 16:37:04 +00:00
userDetailsSelect
:: PGS.Connection
-> Int
-> MateHandler UserDetails
userDetailsSelect conn id = do
today <- utctDay <$> (liftIO $ getCurrentTime)
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant id
) <<< queryTable userTable
) :: MateHandler
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
head <$> mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
UserDetails i2 i3 i5 i6 (AuthSalt i7) (toEnum <$> i9)
)
users
2019-07-20 16:36:47 +00:00
userBalanceSelect
:: PGS.Connection
-> Int
-> MateHandler Int
userBalanceSelect conn id = do
today <- utctDay <$> (liftIO $ getCurrentTime)
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant id
) <<< queryTable userTable
) :: MateHandler
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
head <$> mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
i3
)
users
2019-04-21 15:27:15 +00:00
insertUser :: UserSubmit -> Day -> ByteString -> Insert [Int]
insertUser us now randSalt = Insert
2019-04-15 20:23:25 +00:00
{ iTable = userTable
, iRows =
[
( C.constant (Nothing :: Maybe Int)
, C.constant (userSubmitIdent us)
, C.constant (0 :: Int)
, C.constant now
, C.constant (userSubmitEmail us)
, C.constant (Nothing :: Maybe Int)
2019-04-21 15:27:15 +00:00
, C.constant randSalt
2019-04-17 08:45:48 +00:00
, C.constant (Nothing :: Maybe ByteString)
, C.constant (Nothing :: Maybe Int)
2019-04-15 20:23:25 +00:00
)
]
2019-04-17 08:45:48 +00:00
, iReturning = rReturning (\(id, _, _, _, _, _, _, _, _) -> id)
2019-04-15 20:23:25 +00:00
, iOnConflict = Nothing
2019-04-16 04:23:08 +00:00
}
2019-05-16 16:37:04 +00:00
updateUserDetails :: Int -> UserDetailsSubmit -> Day -> Update Int64
2019-07-20 16:36:47 +00:00
updateUserDetails uid uds now = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, _, i7, i8, _) ->
2019-04-16 04:23:08 +00:00
( id_
2019-05-16 16:37:04 +00:00
, C.constant (userDetailsSubmitIdent uds)
, i3
2019-05-09 14:53:19 +00:00
, C.constant now
2019-05-16 16:37:04 +00:00
, C.constant (userDetailsSubmitEmail uds)
, C.constant (userDetailsSubmitAvatar uds)
2019-04-17 08:45:48 +00:00
, i7
2019-05-16 16:37:04 +00:00
, C.constant ((\(AuthHash h) -> h) <$> userDetailsSubmitHash uds)
, C.constant (fromEnum <$> userDetailsSubmitAlgo uds)
2019-04-16 04:23:08 +00:00
)
)
2019-07-20 16:36:47 +00:00
, uWhere = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant uid)
, uReturning = rCount
}
addToUserBalance
:: Int
-> Int
-> Update Int64
addToUserBalance uid amount = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\(id_, i2, i3, i4, i5, i6, i7, i8, i9) ->
( id_
, i2
, i3 + C.constant amount
, i4
, i5
, i6
, i7
, i8
, i9
)
)
, uWhere = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant uid)
, uReturning = rCount
2019-04-16 04:23:08 +00:00
}