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-04-17 05:51:15 +00:00
-> Bool
2019-05-09 14:53:19 +00:00
-> MateHandler [ User ]
2019-04-17 05:51:15 +00:00
userSelect conn ref sw = 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-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
updateUserDetails id uds now = Update
2019-04-16 04:23:08 +00:00
{ uTable = userTable
2019-05-17 16:37:35 +00:00
, 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 )
2019-05-17 16:37:35 +00:00
, 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-04-17 08:45:48 +00:00
, uWhere = ( \ ( i1 , _ , _ , _ , _ , _ , _ , _ , _ ) -> i1 .== C . constant id )
2019-04-16 04:23:08 +00:00
, uReturning = rCount
}