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
}