mateamt/src/Model/User.hs

219 lines
5.2 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-17 08:45:48 +00:00
import Data.Profunctor.Product (p9)
2019-04-15 20:23:25 +00:00
import Data.Aeson
import Data.Int (Int64)
2019-04-17 08:45:48 +00:00
import Data.Maybe (fromJust, fromMaybe)
import Data.ByteString hiding (head)
2019-04-15 20:23:25 +00:00
import qualified Database.PostgreSQL.Simple as PGS
import GHC.Generics
import Control.Arrow ((<<<))
import Opaleye as O
import qualified Opaleye.Constant as C
-- internal imports
2019-04-17 05:51:15 +00:00
import Types.Refine
2019-04-17 08:45:48 +00:00
import Types.Auth
2019-04-17 05:51:15 +00:00
data User
= User
{ userId :: Int
, userIdent :: T.Text
, userBalance :: Int
, userTimeStamp :: Day
, userEmail :: Maybe T.Text
, userAvatar :: Maybe Int
2019-04-17 08:45:48 +00:00
, userSalt :: AuthSalt
, userHash :: Maybe AuthHash
, userAlgo :: Maybe Int
2019-04-17 05:51:15 +00:00
}
| QueryUser
{ userId :: Int
, userIdent :: T.Text
, userAvatar :: Maybe Int
}
deriving (Generic, Show)
2019-04-15 20:23:25 +00:00
instance ToJSON User where
2019-04-17 08:45:48 +00:00
toEncoding (User id ident balance ts email avatar _ _ _) =
2019-04-16 04:23:08 +00:00
pairs
( "userId" .= id
<> "userIdent" .= ident
<> "userBalance" .= balance
<> "userTimeStamp" .= ts
<> "userEmail" .= email
<> "userAvatar" .= avatar
)
2019-04-17 05:51:15 +00:00
toEncoding (QueryUser id ident avatar) =
pairs
( "userId" .= id
<> "userIdent" .= ident
<> "userAvatar" .= avatar
)
2019-04-15 20:23:25 +00:00
instance FromJSON User
data UserSubmit = UserSubmit
{ userSubmitIdent :: T.Text
, userSubmitEmail :: Maybe T.Text
2019-04-17 08:45:48 +00:00
--, userSubmitPin :: Maybe T.Text
2019-04-15 20:23:25 +00:00
}
deriving (Generic, Show)
instance ToJSON UserSubmit where
toEncoding = genericToEncoding defaultOptions
instance FromJSON UserSubmit
2019-04-16 11:03:07 +00:00
initUser :: PGS.Query
2019-04-17 08:45:48 +00:00
initUser = "create table if not exists \"user\" (id serial primary key, ident varchar(128) not null, balance integer not null, time_stamp date not null, email varchar(128), avatar integer, salt bytea not null, hash bytea, 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-15 20:23:25 +00:00
( tableField "id"
, tableField "ident"
, tableField "balance"
, tableField "time_stamp"
, tableField "email"
, tableField "avatar"
2019-04-17 08:45:48 +00:00
, tableField "salt"
, tableField "hash"
, tableField "algo"
2019-04-15 20:23:25 +00:00
)
)
userSelect
:: PGS.Connection
-> Maybe Refine
2019-04-17 05:51:15 +00:00
-> Bool
2019-04-15 20:23:25 +00:00
-> IO [User]
2019-04-17 05:51:15 +00:00
userSelect conn ref sw = do
2019-04-15 20:23:25 +00:00
today <- utctDay <$> getCurrentTime
2019-04-17 05:51:15 +00:00
users <- 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-04-17 08:45:48 +00:00
) :: IO
[ ( 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-04-17 05:51:15 +00:00
if sw
2019-04-17 08:45:48 +00:00
then User i1 i2 i3 i4 i5 i6 (AuthSalt i7) (AuthHash <$> i8) (toEnum <$> i9)
2019-04-17 05:51:15 +00:00
else QueryUser 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
2019-04-17 08:45:48 +00:00
getUserAuthInfo
:: PGS.Connection
-> Int
-> IO AuthInfo
getUserAuthInfo conn id = do
users <- runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant id) <<< queryTable userTable
) :: IO
[ ( 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 $
2019-04-17 09:09:49 +00:00
AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9)
2019-04-17 08:45:48 +00:00
)
users
2019-04-15 20:23:25 +00:00
insertUser :: UserSubmit -> Day -> Insert [Int]
insertUser us now = 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)
2019-04-17 08:45:48 +00:00
, C.constant ("mocksalt" :: ByteString)
, 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
}
updateUser :: Int -> UserSubmit -> Day -> Update Int64
updateUser id us now = Update
{ uTable = userTable
2019-04-17 08:45:48 +00:00
, uUpdateWith = updateEasy (\(id_, _, i3, _, _, i6, i7, i8, i9) ->
2019-04-16 04:23:08 +00:00
( id_
, C.constant (userSubmitIdent us)
, i3
, C.constant (now)
, C.constant (userSubmitEmail us)
, i6
2019-04-17 08:45:48 +00:00
, i7
, i8
, i9
2019-04-16 04:23:08 +00:00
)
)
2019-04-17 08:45:48 +00:00
, uWhere = (\(i1, _, _, _, _, _, _, _, _) -> i1 .== C.constant id)
2019-04-16 04:23:08 +00:00
, uReturning = rCount
}