2019-08-14 16:04:16 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Control.User where
|
|
|
|
|
|
|
|
import Servant
|
|
|
|
|
2020-05-10 06:36:43 +00:00
|
|
|
import Control.Monad (void, when)
|
2019-08-14 16:04:16 +00:00
|
|
|
|
2019-10-14 20:50:42 +00:00
|
|
|
import Control.Monad.Reader (asks)
|
2019-08-14 16:04:16 +00:00
|
|
|
|
|
|
|
import Control.Monad.IO.Class (liftIO)
|
|
|
|
|
2022-04-17 14:38:48 +00:00
|
|
|
import Crypto.Error
|
|
|
|
|
|
|
|
import Data.String (fromString)
|
|
|
|
|
|
|
|
import Data.Text.Encoding
|
|
|
|
|
2019-08-14 16:04:16 +00:00
|
|
|
import Data.Time (getCurrentTime, utctDay)
|
|
|
|
|
2019-09-11 02:04:06 +00:00
|
|
|
import Data.Maybe (fromMaybe)
|
|
|
|
|
2019-08-14 16:04:16 +00:00
|
|
|
import qualified Data.Text as T
|
|
|
|
|
2021-06-24 04:33:05 +00:00
|
|
|
import Text.Printf (printf)
|
|
|
|
|
2019-08-14 16:04:16 +00:00
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Types
|
|
|
|
import Model
|
2021-06-24 04:33:05 +00:00
|
|
|
import Util
|
2022-04-17 14:38:48 +00:00
|
|
|
import Util.Crypto
|
2019-08-14 16:04:16 +00:00
|
|
|
|
2019-09-15 12:59:22 +00:00
|
|
|
userNew
|
|
|
|
:: UserSubmit
|
|
|
|
-> MateHandler Int
|
2022-04-17 14:38:48 +00:00
|
|
|
userNew (UserSubmit ident email pass) = do
|
2019-10-14 20:50:42 +00:00
|
|
|
now <- liftIO getCurrentTime
|
|
|
|
conn <- asks rsConnection
|
2019-09-15 14:11:56 +00:00
|
|
|
uid <- insertUser ident email (utctDay now) conn
|
2022-04-17 14:38:48 +00:00
|
|
|
salt <- liftIO randomString
|
|
|
|
let mpasshash = argon2 salt (encodeUtf8 pass)
|
|
|
|
case mpasshash of
|
|
|
|
CryptoPassed passhash -> do
|
|
|
|
liftIO $ print passhash
|
|
|
|
void $ putUserAuthInfo uid PrimaryPass "Initial password" salt passhash conn
|
|
|
|
CryptoFailed err ->
|
|
|
|
throwError $ err500
|
|
|
|
{ errBody = "Crypto error: " <> fromString (show err)
|
|
|
|
}
|
2020-07-19 05:01:53 +00:00
|
|
|
baseRoleId <- queryRoleIdByCapabilities
|
2020-08-24 16:52:17 +00:00
|
|
|
(False, False, False, False, False, False, False, False, False, False)
|
2020-07-19 10:27:28 +00:00
|
|
|
conn
|
|
|
|
void $ associateUserToRole uid baseRoleId conn
|
2019-09-15 14:11:56 +00:00
|
|
|
return uid
|
2019-08-14 16:04:16 +00:00
|
|
|
|
2019-09-15 12:59:22 +00:00
|
|
|
userGet
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> MateHandler UserDetails
|
2019-10-14 15:39:28 +00:00
|
|
|
userGet Nothing =
|
2019-09-11 11:54:18 +00:00
|
|
|
throwError $ err401
|
2019-09-06 19:44:31 +00:00
|
|
|
{ errBody = "No Authentication present."
|
2019-08-14 16:04:16 +00:00
|
|
|
}
|
2019-10-14 15:39:28 +00:00
|
|
|
userGet (Just (uid, _)) = do
|
2019-10-14 20:50:42 +00:00
|
|
|
conn <- asks rsConnection
|
2019-10-14 15:39:28 +00:00
|
|
|
userDetailsSelect uid conn
|
2019-08-14 16:04:16 +00:00
|
|
|
|
2022-02-20 20:48:16 +00:00
|
|
|
userGetAll
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> MateHandler [UserDetails]
|
|
|
|
userGetAll Nothing =
|
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "No Authentication present."
|
|
|
|
}
|
|
|
|
userGetAll (Just (_, _)) = do
|
|
|
|
conn <- asks rsConnection
|
|
|
|
userDetailsSelectAll conn
|
|
|
|
|
2019-09-15 12:59:22 +00:00
|
|
|
userUpdate
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> UserDetailsSubmit
|
|
|
|
-> MateHandler ()
|
2019-09-16 06:59:57 +00:00
|
|
|
userUpdate Nothing _ =
|
2019-09-11 11:54:18 +00:00
|
|
|
throwError $ err401
|
2019-09-06 19:44:31 +00:00
|
|
|
{ errBody = "No Authentication present."
|
2019-08-14 16:04:16 +00:00
|
|
|
}
|
2019-09-16 06:59:57 +00:00
|
|
|
userUpdate (Just (aid, method)) uds =
|
2019-10-14 21:34:45 +00:00
|
|
|
if method `elem` [PrimaryPass, ChallengeResponse]
|
2019-08-14 16:04:16 +00:00
|
|
|
then do
|
2019-10-14 20:50:42 +00:00
|
|
|
now <- liftIO getCurrentTime
|
|
|
|
conn <- asks rsConnection
|
2019-09-16 06:59:57 +00:00
|
|
|
void $ updateUserDetails aid uds (utctDay now) conn
|
2019-08-14 16:04:16 +00:00
|
|
|
else
|
2019-09-11 11:54:18 +00:00
|
|
|
throwError $ err401
|
2019-09-06 19:44:31 +00:00
|
|
|
{ errBody = "Wrong Authentication present."
|
2019-08-14 16:04:16 +00:00
|
|
|
}
|
|
|
|
|
2019-12-26 08:26:32 +00:00
|
|
|
userUpdateTimestamp
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> MateHandler ()
|
|
|
|
userUpdateTimestamp (Just (aid, _)) = do
|
|
|
|
now <- liftIO getCurrentTime
|
|
|
|
conn <- asks rsConnection
|
|
|
|
void $ updateUserTimestamp aid (utctDay now) conn
|
|
|
|
userUpdateTimestamp Nothing =
|
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "No Authentication present."
|
|
|
|
}
|
|
|
|
|
2019-09-15 12:59:22 +00:00
|
|
|
userList
|
|
|
|
:: Maybe UserRefine
|
|
|
|
-> MateHandler [UserSummary]
|
2019-09-09 10:53:07 +00:00
|
|
|
userList ref = do
|
2019-10-14 20:50:42 +00:00
|
|
|
conn <- asks rsConnection
|
2019-09-11 02:04:06 +00:00
|
|
|
userSelect (fromMaybe ActiveUsers ref) conn
|
2019-08-14 16:04:16 +00:00
|
|
|
|
2019-09-15 12:59:22 +00:00
|
|
|
userRecharge
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> UserRecharge
|
|
|
|
-> MateHandler ()
|
2020-05-10 06:36:43 +00:00
|
|
|
userRecharge (Just (auid, _)) (UserRecharge amount) = do
|
2020-05-10 08:06:10 +00:00
|
|
|
when (amount < 0) $
|
2019-09-06 19:43:46 +00:00
|
|
|
throwError $ err400
|
|
|
|
{ errBody = "Amounts less or equal zero are not acceptable."
|
|
|
|
}
|
2020-05-10 06:36:43 +00:00
|
|
|
conn <- asks rsConnection
|
|
|
|
ud <- userDetailsSelect auid conn
|
|
|
|
void $ insertNewJournalEntry
|
|
|
|
(JournalSubmit
|
2020-05-10 09:29:07 +00:00
|
|
|
(Just $ userDetailsId ud)
|
|
|
|
Recharge
|
2020-05-10 06:36:43 +00:00
|
|
|
amount
|
|
|
|
)
|
|
|
|
conn
|
|
|
|
void $ addToUserBalance auid amount conn
|
2019-09-06 19:43:46 +00:00
|
|
|
userRecharge Nothing _ =
|
2019-09-11 11:54:18 +00:00
|
|
|
throwError $ err401
|
2019-09-06 19:43:46 +00:00
|
|
|
{ errBody = "No Authentication present."
|
|
|
|
}
|
|
|
|
|
2019-09-15 12:59:22 +00:00
|
|
|
userTransfer
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> UserTransfer
|
|
|
|
-> MateHandler ()
|
2020-05-10 06:36:43 +00:00
|
|
|
userTransfer (Just (auid, method)) (UserTransfer target amount) = do
|
2020-05-10 08:06:10 +00:00
|
|
|
when (amount < 0) $
|
2019-09-06 19:44:31 +00:00
|
|
|
throwError $ err400
|
|
|
|
{ errBody = "Amounts less or equal zero are not acceptable."
|
2019-08-14 16:04:16 +00:00
|
|
|
}
|
2020-05-10 08:06:10 +00:00
|
|
|
when (auid == target) $
|
2020-05-10 06:36:43 +00:00
|
|
|
throwError $ err400
|
|
|
|
{ errBody = "You can not transfer yourself money."
|
|
|
|
}
|
2020-05-10 08:06:10 +00:00
|
|
|
when (method `notElem` [PrimaryPass, ChallengeResponse]) $
|
2020-05-10 06:36:43 +00:00
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "No Authentication present."
|
|
|
|
}
|
|
|
|
conn <- asks rsConnection
|
|
|
|
user <- userDetailsSelect auid conn
|
2020-05-10 08:06:10 +00:00
|
|
|
when (amount > userDetailsBalance user) $
|
2020-05-10 06:36:43 +00:00
|
|
|
throwError $ err400
|
|
|
|
{ errBody = "Not enough credit balance."
|
|
|
|
}
|
|
|
|
mtarget <- filter (\u -> userSummaryId u == target) <$> userSelect AllUsers conn
|
2020-05-10 08:06:10 +00:00
|
|
|
when (null mtarget) $
|
2020-05-10 06:36:43 +00:00
|
|
|
throwError $ err400
|
|
|
|
{ errBody = "Target user not found."
|
|
|
|
}
|
|
|
|
void $ addToUserBalance auid (-amount) conn
|
|
|
|
void $ addToUserBalance target amount conn
|
2019-09-06 19:43:46 +00:00
|
|
|
userTransfer Nothing _ =
|
2019-09-11 11:54:18 +00:00
|
|
|
throwError $ err401
|
2019-09-06 19:43:46 +00:00
|
|
|
{ errBody = "No Authentication present."
|
2019-08-14 16:04:16 +00:00
|
|
|
}
|
2021-02-15 18:00:29 +00:00
|
|
|
|
|
|
|
userNotify
|
|
|
|
:: Maybe (Int, AuthMethod)
|
|
|
|
-> [PurchaseDetail]
|
|
|
|
-> PurchaseResult
|
|
|
|
-> MateHandler ()
|
2021-07-14 01:08:58 +00:00
|
|
|
userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do
|
2021-06-10 15:54:57 +00:00
|
|
|
conn <- asks rsConnection
|
2021-06-16 16:09:08 +00:00
|
|
|
authOV <- selectAuthOverviewById auid conn
|
|
|
|
userDetails <- userDetailsSelect (authOverviewUser authOV) conn
|
2021-06-10 15:54:57 +00:00
|
|
|
digestedDetails <- mapM
|
|
|
|
(\pd -> do
|
2021-06-16 16:09:08 +00:00
|
|
|
overview <- productOverviewSelectSingle (purchaseDetailProduct pd) conn
|
2021-07-02 20:53:09 +00:00
|
|
|
return
|
|
|
|
( purchaseDetailAmount pd
|
|
|
|
, productOverviewIdent overview
|
|
|
|
, productOverviewPrice overview
|
|
|
|
)
|
2021-06-10 15:54:57 +00:00
|
|
|
)
|
|
|
|
boughtItems
|
2021-07-12 11:29:40 +00:00
|
|
|
currencyFrac <- asks rsCurrencyFraction
|
2021-07-02 20:53:09 +00:00
|
|
|
currencySymb <- asks rsCurrencySymbol
|
2021-07-14 01:08:58 +00:00
|
|
|
let messageText = T.pack $ mconcat $ map (<> "\n") $
|
2021-06-24 04:33:05 +00:00
|
|
|
[ printf (__ "Hello %s,") (userDetailsIdent userDetails)
|
|
|
|
, ""
|
|
|
|
, printf (__ "Your authentication key with the comment \"%s\"\
|
|
|
|
\ Just made following purchase:")
|
|
|
|
(authOverviewComment authOV)
|
2021-06-10 15:54:57 +00:00
|
|
|
, ""
|
2021-07-02 20:53:09 +00:00
|
|
|
] ++
|
2021-07-14 01:08:58 +00:00
|
|
|
map
|
2021-07-02 20:53:09 +00:00
|
|
|
(\(amount, ident, price) ->
|
|
|
|
printf
|
|
|
|
("%dx %s " <>
|
2021-07-14 01:08:58 +00:00
|
|
|
__ "for the price of" <>
|
2021-07-02 20:53:09 +00:00
|
|
|
"%d %f." <>
|
2021-07-14 01:08:58 +00:00
|
|
|
printf "%d" currencyFrac <>
|
|
|
|
printf "%s" currencySymb
|
2021-07-02 20:53:09 +00:00
|
|
|
)
|
|
|
|
amount
|
|
|
|
ident
|
|
|
|
price
|
|
|
|
)
|
2021-07-12 11:29:40 +00:00
|
|
|
digestedDetails
|
2021-07-02 20:53:09 +00:00
|
|
|
++
|
|
|
|
[ ""
|
|
|
|
, printf (__ "For a total price of %s%s") <>
|
2021-07-14 01:08:58 +00:00
|
|
|
printf
|
2021-07-12 11:29:40 +00:00
|
|
|
("%f." <>
|
|
|
|
(printf "%d" currencyFrac :: String))
|
2021-07-14 01:08:58 +00:00
|
|
|
(fromIntegral (
|
2021-07-12 11:29:40 +00:00
|
|
|
foldl (\acc (_, _, p) -> acc + p)
|
|
|
|
0
|
|
|
|
digestedDetails
|
|
|
|
) /
|
2021-07-14 01:08:58 +00:00
|
|
|
fromIntegral (10 ^ currencyFrac :: Int)
|
|
|
|
:: Float )
|
2021-07-12 11:29:40 +00:00
|
|
|
currencySymb
|
|
|
|
, ""
|
2021-07-14 01:08:58 +00:00
|
|
|
, __ "Enjoy your purchased items!\n\nSincerely,\nMateamt"
|
|
|
|
] ++
|
|
|
|
[ __ "P.S.: You are now in debt. Please recharge your credit." |
|
|
|
|
flag == PurchaseDebtful ]
|
2021-07-12 11:29:40 +00:00
|
|
|
case userDetailsEmail userDetails of
|
|
|
|
Just _ -> do
|
|
|
|
sendUserNotification
|
|
|
|
userDetails
|
|
|
|
(__ "Purchase notification")
|
|
|
|
messageText
|
|
|
|
Nothing ->
|
|
|
|
return ()
|
2021-07-14 01:08:58 +00:00
|
|
|
userNotify Nothing _ _ =
|
|
|
|
throwError $ err401
|
|
|
|
{ errBody = "No Authentication present."
|
|
|
|
}
|