mateamt/src/Model/User.hs
2019-09-09 12:54:56 +02:00

240 lines
5.7 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 (p9)
import Data.ByteString hiding (head, foldl)
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.Auth
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,"
, "user_salt BYTEA NOT NULL,"
, "user_hash BYTEA,"
, "user_algo INTEGER"
, ")"
]
userTable :: Table
( Maybe (Field SqlInt4)
, Field SqlText
, Field SqlInt4
, Field SqlDate
, FieldNullable SqlText
, FieldNullable SqlInt4
, Field SqlBytea
, FieldNullable SqlBytea
, FieldNullable SqlInt4
)
( Field SqlInt4
, Field SqlText
, Field SqlInt4
, Field SqlDate
, FieldNullable SqlText
, FieldNullable SqlInt4
, Field SqlBytea
, FieldNullable SqlBytea
, FieldNullable SqlInt4
)
userTable = table "user" (
p9
( 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"
)
)
userSelect
:: Maybe UserRefine
-> PGS.Connection
-> MateHandler [UserSummary]
userSelect ref conn = do
today <- utctDay <$> (liftIO $ getCurrentTime)
users <- liftIO $ runSelect conn (case ref of
Nothing -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
ts .>= C.constant (addDays (-30) today)
) <<< queryTable userTable
Just AllUsers -> selectTable userTable
Just OldUsers -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
ts .<= C.constant (addDays (-30) today)
) <<< queryTable userTable
) :: MateHandler
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
mapM
(\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
-- User i1 i2 i3 i4 i5 i6 (AuthSalt i7) (AuthHash <$> i8) (toEnum <$> i9)
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
, ByteString
, Maybe ByteString
, Maybe Int
)
]
head <$> mapM
(\(i1, i2, i3, _, i5, i6, i7, _, i9) -> return $
UserDetails i1 i2 i3 i5 i6 (AuthSalt i7) (toEnum <$> i9)
)
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
, ByteString
, Maybe ByteString
, Maybe Int
)
]
head <$> mapM
(\(_, _, i3, _, _, _, _, _, _) -> return $
i3
)
users
insertUser
:: UserSubmit
-> Day
-> ByteString
-> PGS.Connection
-> MateHandler Int
insertUser us now randSalt conn = fmap head $ liftIO $ runInsert_ conn $ Insert
{ 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)
, C.constant randSalt
, C.constant (Nothing :: Maybe ByteString)
, 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, _, _, _, i7, _, _) ->
( id_
, C.constant (userDetailsSubmitIdent uds)
, i3
, C.constant now
, C.constant (userDetailsSubmitEmail uds)
, C.constant (userDetailsSubmitAvatar uds)
, i7
, C.constant ((\(AuthHash h) -> h) <$> userDetailsSubmitHash uds)
, C.constant (fromEnum <$> userDetailsSubmitAlgo uds)
)
)
, 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, i7, i8, i9) ->
( id_
, i2
, i3 + C.constant amount
, i4
, i5
, i6
, i7
, i8
, i9
)
)
, uWhere = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant uid)
, uReturning = rCount
}